From f94bb5ca9f038bbdc62e5a3a00a253818c0ac0b9 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 21 Sep 2026 18:06:02 +0000 Subject: [PATCH 01/46] =?UTF-8?q?Import=20A=20proof=20of=20the=20Regts?= =?UTF-8?q?=E2=80=93Sevenster=20conjecture,=20formalized?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- LeanPool.lean | 838 ++++++ LeanPool/RegtsSevenster.lean | 854 ++++++ LeanPool/RegtsSevenster/RS.lean | 28 + .../RegtsSevenster/RS/Assembly/Blueprint.lean | 1048 +++++++ .../RS/Assembly/BlueprintConverse.lean | 180 ++ .../RS/Assembly/BlueprintDeligne.lean | 87 + .../RS/Assembly/BlueprintFactorial.lean | 269 ++ .../RS/Assembly/BlueprintSchur.lean | 462 +++ .../RS/Assembly/BlueprintStatement.lean | 492 ++++ LeanPool/RegtsSevenster/RS/Classical.lean | 143 + .../RS/Classical/Algebra/FactorialTrace.lean | 134 + .../RS/Classical/Algebra/TraceCriterion.lean | 63 + .../RS/Classical/CatTheory/Growth.lean | 59 + .../RS/Classical/CatTheory/Intertwine.lean | 34 + .../RS/Classical/CatTheory/KaroubiLinear.lean | 61 + .../RS/Classical/CatTheory/KaroubiTrace.lean | 68 + .../RS/Classical/CatTheory/Length.lean | 323 +++ .../RS/Classical/CatTheory/LengthBound.lean | 196 ++ .../Classical/CatTheory/LinearCategory.lean | 38 + .../RS/Classical/CatTheory/PartialTrace.lean | 296 ++ .../RS/Classical/CatTheory/TensorPow.lean | 74 + .../RS/Classical/CatTheory/Trace.lean | 388 +++ .../RS/Classical/CatTheory/UnitEnd.lean | 78 + .../Classical/CatTheory/WhiskerAdditive.lean | 178 ++ .../RegtsSevenster/RS/Classical/Deligne.lean | 341 +++ .../RS/Classical/Deligne/AltPow.lean | 258 ++ .../RS/Classical/Deligne/AltPowAct.lean | 181 ++ .../Classical/Deligne/BaseChangeAdjoint.lean | 807 ++++++ .../Classical/Deligne/BaseChangeBiprod.lean | 391 +++ .../Deligne/BaseChangeCoherence.lean | 827 ++++++ .../RS/Classical/Deligne/BaseChangeDatum.lean | 168 ++ .../RS/Classical/Deligne/BaseChangeFree.lean | 354 +++ .../Classical/Deligne/BaseChangeLinear.lean | 596 ++++ .../Classical/Deligne/BaseChangeMonoidal.lean | 614 ++++ .../Classical/Deligne/BaseChangeTensor.lean | 713 +++++ .../Deligne/BaseChangeTransport.lean | 634 +++++ .../Classical/Deligne/BaseChangeZigzag.lean | 41 + .../RS/Classical/Deligne/BigTensor.lean | 1181 ++++++++ .../RS/Classical/Deligne/BigTensorUnit.lean | 90 + .../RS/Classical/Deligne/BiprodPow.lean | 1418 ++++++++++ .../RS/Classical/Deligne/BiprodTransfer.lean | 337 +++ .../RS/Classical/Deligne/BlockUnits.lean | 346 +++ .../RS/Classical/Deligne/BraidCoherence.lean | 65 + .../RS/Classical/Deligne/ChainAlgebra.lean | 780 +++++ .../RS/Classical/Deligne/ChainB.lean | 332 +++ .../RS/Classical/Deligne/ChainBGr.lean | 1603 +++++++++++ .../RS/Classical/Deligne/ChainBGraded.lean | 568 ++++ .../Classical/Deligne/ChainBGradedLaws.lean | 420 +++ .../RS/Classical/Deligne/ChainBInd.lean | 114 + .../RS/Classical/Deligne/ChainBNonzero.lean | 44 + .../RS/Classical/Deligne/ChainBofA.lean | 352 +++ .../RS/Classical/Deligne/ChainBridge.lean | 493 ++++ .../RS/Classical/Deligne/ChainDelta.lean | 173 ++ .../RS/Classical/Deligne/ChainIns.lean | 18 + .../RS/Classical/Deligne/ChainIns/Base.lean | 643 +++++ .../Classical/Deligne/ChainIns/FirstSlot.lean | 1054 +++++++ .../Deligne/ChainIns/SecondSlot.lean | 1255 +++++++++ .../RS/Classical/Deligne/ChainMul.lean | 222 ++ .../RS/Classical/Deligne/ChainMulHet.lean | 262 ++ .../RS/Classical/Deligne/ChainMulLaws.lean | 961 +++++++ .../RS/Classical/Deligne/ChainNonzero.lean | 117 + .../RS/Classical/Deligne/ChainShift.lean | 212 ++ .../RS/Classical/Deligne/ChainStage2.lean | 1128 ++++++++ .../RS/Classical/Deligne/ChainUnit.lean | 91 + .../RS/Classical/Deligne/CharSplit.lean | 405 +++ .../RS/Classical/Deligne/CommonAlgebra.lean | 50 + .../RS/Classical/Deligne/CoprodPreserve.lean | 163 ++ .../Classical/Deligne/CountableDescent.lean | 885 ++++++ .../Deligne/CountableDescentClose.lean | 584 ++++ .../Deligne/CountableNullstellensatz.lean | 80 + .../RS/Classical/Deligne/CoverFactor.lean | 408 +++ .../RS/Classical/Deligne/CycleSplit.lean | 509 ++++ .../RS/Classical/Deligne/DayCalculus.lean | 337 +++ .../RS/Classical/Deligne/DayType.lean | 382 +++ .../RS/Classical/Deligne/DeligneAssembly.lean | 323 +++ .../RS/Classical/Deligne/DescentClose.lean | 68 + .../RS/Classical/Deligne/DevissageBound.lean | 78 + .../RS/Classical/Deligne/DoubledAbelian.lean | 200 ++ .../RS/Classical/Deligne/DoubledGrowth.lean | 583 ++++ .../RS/Classical/Deligne/DoubledLine.lean | 37 + .../RS/Classical/Deligne/DoubledScalar.lean | 47 + .../RS/Classical/Deligne/DoubledSmall.lean | 46 + .../RS/Classical/Deligne/DoubledSplit.lean | 68 + .../RS/Classical/Deligne/Doubling.lean | 1755 ++++++++++++ .../RS/Classical/Deligne/DualityMate.lean | 34 + .../Classical/Deligne/EvenEmbedMonoidal.lean | 248 ++ .../RS/Classical/Deligne/ExactFromShort.lean | 74 + .../RS/Classical/Deligne/FactorialBeats.lean | 103 + .../RS/Classical/Deligne/FibreAdditive.lean | 96 + .../RS/Classical/Deligne/FibreBridge.lean | 47 + .../RS/Classical/Deligne/FibreEps.lean | 76 + .../RS/Classical/Deligne/FibreExact.lean | 352 +++ .../RS/Classical/Deligne/FibreFaithful.lean | 165 ++ .../RS/Classical/Deligne/FibreFunctor.lean | 62 + .../RS/Classical/Deligne/FibreLinear.lean | 48 + .../RS/Classical/Deligne/FibreMix.lean | 62 + .../RS/Classical/Deligne/FibreMonoidal.lean | 678 +++++ .../RS/Classical/Deligne/FibreMu.lean | 159 ++ .../RS/Classical/Deligne/FibreMuNat.lean | 127 + .../Classical/Deligne/FibreOverComplex.lean | 338 +++ .../Classical/Deligne/FibreOverSplitting.lean | 161 ++ .../RS/Classical/Deligne/FibreRestrict.lean | 86 + .../RS/Classical/Deligne/FibreStrong.lean | 75 + .../RS/Classical/Deligne/FiltNil.lean | 189 ++ .../RS/Classical/Deligne/FlatLimit.lean | 406 +++ .../RS/Classical/Deligne/FreeCollapseAlg.lean | 74 + .../RS/Classical/Deligne/FreeMixRetract.lean | 47 + .../RS/Classical/Deligne/FreeModAdjoint.lean | 226 ++ .../RS/Classical/Deligne/FreeModBiprod.lean | 45 + .../RS/Classical/Deligne/FreeModFunctor.lean | 65 + .../RS/Classical/Deligne/FreeModShuffle.lean | 187 ++ .../Classical/Deligne/FreeModShuffleCoh.lean | 183 ++ .../RS/Classical/Deligne/FreeModTensor.lean | 383 +++ .../RS/Classical/Deligne/FreeNormalise.lean | 178 ++ .../Classical/Deligne/FreeNormaliseBase.lean | 58 + .../Classical/Deligne/FreeNormaliseStep.lean | 208 ++ .../RS/Classical/Deligne/FreePow.lean | 236 ++ .../RS/Classical/Deligne/FreePowDesc.lean | 399 +++ .../RS/Classical/Deligne/FreePowInsert.lean | 230 ++ .../RS/Classical/Deligne/FreeSlide.lean | 156 + .../RS/Classical/Deligne/FreeSummand.lean | 864 ++++++ .../RS/Classical/Deligne/FreeTwistPi.lean | 103 + .../RS/Classical/Deligne/GammaAlgebra.lean | 306 ++ .../RS/Classical/Deligne/GammaBiprod.lean | 101 + .../RS/Classical/Deligne/GammaComplex.lean | 60 + .../RS/Classical/Deligne/GammaCountable.lean | 626 +++++ .../RS/Classical/Deligne/GammaModule.lean | 355 +++ .../Classical/Deligne/GammaModuleFunctor.lean | 48 + .../RS/Classical/Deligne/GammaPair.lean | 1045 +++++++ .../RS/Classical/Deligne/GammaPairAdd.lean | 141 + .../Classical/Deligne/GammaPairFreeFree.lean | 112 + .../Classical/Deligne/GammaPairFreeMix.lean | 84 + .../RS/Classical/Deligne/GammaPairNat.lean | 357 +++ .../Classical/Deligne/GammaPairRetract.lean | 160 ++ .../Deligne/GammaPairRetractRight.lean | 214 ++ .../RS/Classical/Deligne/GammaPairUnit.lean | 330 +++ .../RS/Classical/Deligne/GammaShift.lean | 253 ++ .../RS/Classical/Deligne/GammaTwistLeft.lean | 384 +++ .../Classical/Deligne/GeneratorAlgebra.lean | 72 + .../RS/Classical/Deligne/GrowthDichotomy.lean | 356 +++ .../RS/Classical/Deligne/HomFinite.lean | 433 +++ .../RS/Classical/Deligne/HookMult.lean | 220 ++ .../RS/Classical/Deligne/HookZero.lean | 407 +++ .../RS/Classical/Deligne/IdemCut.lean | 711 +++++ .../Classical/Deligne/IdempotentLength.lean | 233 ++ .../RS/Classical/Deligne/ImageSubalgebra.lean | 688 +++++ .../RS/Classical/Deligne/IndAllColim.lean | 67 + .../Classical/Deligne/IndBigTensorUnit.lean | 62 + .../RS/Classical/Deligne/IndCoeq.lean | 913 ++++++ .../RS/Classical/Deligne/IndCompact.lean | 167 ++ .../RS/Classical/Deligne/IndDayClosure.lean | 145 + .../RS/Classical/Deligne/IndImage.lean | 269 ++ .../RS/Classical/Deligne/IndKill.lean | 475 ++++ .../RS/Classical/Deligne/IndLocallyMixed.lean | 50 + .../RS/Classical/Deligne/IndMonoidal.lean | 130 + .../RS/Classical/Deligne/IndOfLinear.lean | 144 + .../RS/Classical/Deligne/IndOfMonoidal.lean | 393 +++ .../RS/Classical/Deligne/IndPointTensor.lean | 313 +++ .../RS/Classical/Deligne/IndSchur.lean | 992 +++++++ .../RS/Classical/Deligne/IndSchurKilled.lean | 331 +++ .../RS/Classical/Deligne/IndSimple.lean | 132 + .../RS/Classical/Deligne/IndSplit.lean | 565 ++++ .../RS/Classical/Deligne/IndSplitSection.lean | 203 ++ .../RS/Classical/Deligne/IndTensorExact.lean | 1407 +++++++++ .../RS/Classical/Deligne/IndUnitNonzero.lean | 41 + .../RS/Classical/Deligne/InitDatum.lean | 189 ++ .../RS/Classical/Deligne/InitState.lean | 63 + .../RS/Classical/Deligne/InterchangeAct.lean | 424 +++ .../RS/Classical/Deligne/KernelPow.lean | 1007 +++++++ .../RS/Classical/Deligne/KeyLemma.lean | 186 ++ .../RS/Classical/Deligne/KeyLemmaClose.lean | 87 + .../RS/Classical/Deligne/KeyLemmaData.lean | 117 + .../RS/Classical/Deligne/KillerNonempty.lean | 54 + .../RS/Classical/Deligne/KronKill.lean | 415 +++ .../RS/Classical/Deligne/LambdaCoend.lean | 1817 ++++++++++++ .../RS/Classical/Deligne/MixDegenerate.lean | 288 ++ .../RS/Classical/Deligne/MixShuffle.lean | 222 ++ .../RS/Classical/Deligne/MixShuffleLine.lean | 208 ++ .../RS/Classical/Deligne/MixSumPow.lean | 237 ++ .../RS/Classical/Deligne/MixWhisker.lean | 238 ++ .../RS/Classical/Deligne/MixWhiskerAll.lean | 56 + .../RS/Classical/Deligne/MixedConc.lean | 650 +++++ .../RS/Classical/Deligne/MixedDiag.lean | 416 +++ .../RS/Classical/Deligne/MixedTransport.lean | 39 + .../RS/Classical/Deligne/ModAbelian.lean | 1643 +++++++++++ .../RS/Classical/Deligne/ModAssoc.lean | 568 ++++ .../RS/Classical/Deligne/ModBiprod.lean | 448 +++ .../RS/Classical/Deligne/ModContractL.lean | 284 ++ .../RS/Classical/Deligne/ModCross.lean | 921 ++++++ .../RS/Classical/Deligne/ModDual.lean | 442 +++ .../RS/Classical/Deligne/ModIns.lean | 314 +++ .../RS/Classical/Deligne/ModMulti.lean | 1482 ++++++++++ .../RS/Classical/Deligne/ModMultiTriple.lean | 519 ++++ .../RS/Classical/Deligne/ModPowCast.lean | 200 ++ .../RS/Classical/Deligne/ModPowDescent.lean | 93 + .../Classical/Deligne/ModPowDescentClose.lean | 50 + .../RS/Classical/Deligne/ModPowStage.lean | 220 ++ .../RS/Classical/Deligne/ModSchur.lean | 236 ++ .../RS/Classical/Deligne/ModSchurSummand.lean | 91 + .../RS/Classical/Deligne/ModTensor.lean | 1097 ++++++++ .../RS/Classical/Deligne/ModZero.lean | 44 + .../RS/Classical/Deligne/MuInterchange.lean | 106 + .../RS/Classical/Deligne/MulBy.lean | 120 + .../RS/Classical/Deligne/NatChain.lean | 92 + .../RS/Classical/Deligne/NewtonConv.lean | 113 + .../RS/Classical/Deligne/NullPoint.lean | 34 + .../RS/Classical/Deligne/OddLineMap.lean | 55 + .../RS/Classical/Deligne/OddLinePairing.lean | 160 ++ .../RS/Classical/Deligne/OddParity.lean | 165 ++ .../RS/Classical/Deligne/OddPermSign.lean | 119 + .../RS/Classical/Deligne/OddSquare.lean | 199 ++ .../RS/Classical/Deligne/OddSquareIso.lean | 379 +++ .../RS/Classical/Deligne/PairCarrier.lean | 112 + .../RS/Classical/Deligne/PairMul.lean | 672 +++++ .../RS/Classical/Deligne/PairPerm.lean | 1072 +++++++ .../RS/Classical/Deligne/PermNat.lean | 390 +++ .../RS/Classical/Deligne/PermRepChar.lean | 318 +++ .../RS/Classical/Deligne/PieriPos.lean | 1529 ++++++++++ .../RS/Classical/Deligne/PlainShuffle.lean | 93 + .../RS/Classical/Deligne/PointBaseChange.lean | 475 ++++ .../RS/Classical/Deligne/PointFibre.lean | 820 ++++++ .../RS/Classical/Deligne/PointMonoidal.lean | 24 + .../Deligne/PointMonoidal/Calculus.lean | 566 ++++ .../Deligne/PointMonoidal/Coherence.lean | 1319 +++++++++ .../Deligne/PointMonoidal/Comparison.lean | 806 ++++++ .../Deligne/PointMonoidal/Functor.lean | 283 ++ .../Deligne/PointMonoidal/Residue.lean | 597 ++++ .../RS/Classical/Deligne/PointTensor.lean | 73 + .../RS/Classical/Deligne/PowAct.lean | 1155 ++++++++ .../RS/Classical/Deligne/PowActMul.lean | 391 +++ .../RS/Classical/Deligne/PowChain.lean | 272 ++ .../RS/Classical/Deligne/PowCopairing.lean | 233 ++ .../RS/Classical/Deligne/PowDatum.lean | 134 + .../RS/Classical/Deligne/PowInduct.lean | 129 + .../RS/Classical/Deligne/PowMerge.lean | 1358 +++++++++ .../RS/Classical/Deligne/PowPairSucc.lean | 583 ++++ .../RS/Classical/Deligne/PowPairing.lean | 1940 +++++++++++++ .../RS/Classical/Deligne/PowPoint.lean | 377 +++ .../RS/Classical/Deligne/PowSucc.lean | 219 ++ .../RS/Classical/Deligne/PowSuccMod.lean | 270 ++ .../RS/Classical/Deligne/PowTriangle.lean | 1030 +++++++ .../RS/Classical/Deligne/PowZig.lean | 313 +++ .../RS/Classical/Deligne/PowZigzag.lean | 120 + .../Classical/Deligne/PresentedQuotient.lean | 335 +++ .../RS/Classical/Deligne/Prop21.lean | 70 + .../RS/Classical/Deligne/Prop21Core.lean | 73 + .../RS/Classical/Deligne/Prop21General.lean | 120 + .../RS/Classical/Deligne/Prop29.lean | 102 + .../RS/Classical/Deligne/Prop29Close.lean | 52 + .../RS/Classical/Deligne/Prop29State.lean | 206 ++ .../RS/Classical/Deligne/Rappel210.lean | 64 + .../RS/Classical/Deligne/Rappel210Bridge.lean | 197 ++ .../RS/Classical/Deligne/Rappel210Chain.lean | 439 +++ .../RS/Classical/Deligne/Rappel210Close.lean | 69 + .../RS/Classical/Deligne/Rappel210Ind.lean | 76 + .../RS/Classical/Deligne/Rappel210Reduce.lean | 768 +++++ .../RS/Classical/Deligne/RegularSum.lean | 1185 ++++++++ .../RS/Classical/Deligne/RhoBiprod.lean | 49 + .../RS/Classical/Deligne/RhoTwist.lean | 65 + .../RS/Classical/Deligne/RowColIdem.lean | 704 +++++ .../RS/Classical/Deligne/SandwichMerge.lean | 152 + .../RS/Classical/Deligne/SandwichRetract.lean | 196 ++ .../RS/Classical/Deligne/SandwichZig.lean | 53 + .../RS/Classical/Deligne/ScalarBraiding.lean | 407 +++ .../RS/Classical/Deligne/ScalarLinear.lean | 402 +++ .../RS/Classical/Deligne/ScalarUnitEquiv.lean | 56 + .../RS/Classical/Deligne/ScalarUnitInd.lean | 61 + .../RS/Classical/Deligne/SchurTransport.lean | 491 ++++ .../RS/Classical/Deligne/SchurVanishing.lean | 64 + .../RS/Classical/Deligne/SeedIns.lean | 2495 ++++++++++++++++ .../RS/Classical/Deligne/ShapeAlgebra.lean | 56 + .../RS/Classical/Deligne/ShapeFintype.lean | 96 + .../RS/Classical/Deligne/SignConj.lean | 277 ++ .../RS/Classical/Deligne/SimpleGenerator.lean | 73 + .../RS/Classical/Deligne/SimplePoint.lean | 84 + .../RS/Classical/Deligne/SimpleQuotient.lean | 726 +++++ .../RS/Classical/Deligne/SimpleScalars.lean | 357 +++ .../RS/Classical/Deligne/SimpleSplit.lean | 631 +++++ .../RS/Classical/Deligne/SmallReduction.lean | 453 +++ .../RS/Classical/Deligne/SplitAdjoint.lean | 154 + .../RS/Classical/Deligne/SplitAssemble.lean | 535 ++++ .../RS/Classical/Deligne/SplitClosure.lean | 427 +++ .../RS/Classical/Deligne/SplitComplement.lean | 739 +++++ .../RS/Classical/Deligne/SplitEverything.lean | 96 + .../RS/Classical/Deligne/SplitExact.lean | 54 + .../RS/Classical/Deligne/SplitExtract.lean | 342 +++ .../Classical/Deligne/SplitExtractDual.lean | 879 ++++++ .../RS/Classical/Deligne/SplitMonHom.lean | 262 ++ .../RS/Classical/Deligne/SplitPairDef.lean | 175 ++ .../RS/Classical/Deligne/SplitReduce.lean | 107 + .../RS/Classical/Deligne/SplitTransport.lean | 100 + .../Classical/Deligne/SplittingAlgebra.lean | 57 + .../RS/Classical/Deligne/StateTransport.lean | 77 + .../RS/Classical/Deligne/StepA.lean | 117 + .../RS/Classical/Deligne/StepATransport.lean | 131 + .../RS/Classical/Deligne/StepB.lean | 51 + .../RS/Classical/Deligne/SuperEmbed.lean | 20 + .../Classical/Deligne/SuperEmbed/Letters.lean | 1399 +++++++++ .../Classical/Deligne/SuperEmbed/Signs.lean | 422 +++ .../Deligne/SuperEmbed/Standard.lean | 892 ++++++ .../RS/Classical/Deligne/SuperEvenRing.lean | 163 ++ .../RS/Classical/Deligne/SuperGamma.lean | 391 +++ .../RS/Classical/Deligne/SuperGammaInst.lean | 766 +++++ .../RS/Classical/Deligne/SuperModAbelian.lean | 701 +++++ .../RS/Classical/Deligne/SuperModBiprod.lean | 260 ++ .../Classical/Deligne/SuperModBiprodMap.lean | 68 + .../RS/Classical/Deligne/SuperModHom.lean | 240 ++ .../RS/Classical/Deligne/SuperModIso.lean | 75 + .../Classical/Deligne/SuperModMonoidal.lean | 2441 ++++++++++++++++ .../RS/Classical/Deligne/SuperModShift.lean | 57 + .../Classical/Deligne/SuperModShiftUnit.lean | 243 ++ .../RS/Classical/Deligne/SuperModTensor.lean | 1141 ++++++++ .../RS/Classical/Deligne/SuperPointMod.lean | 82 + .../RS/Classical/Deligne/SuperRealize.lean | 811 ++++++ .../RS/Classical/Deligne/SuperSeries.lean | 239 ++ .../RS/Classical/Deligne/SuperSmall.lean | 619 ++++ .../RS/Classical/Deligne/SuperValues.lean | 59 + .../RS/Classical/Deligne/SuperVectSchur.lean | 1258 +++++++++ .../RS/Classical/Deligne/SymAlg.lean | 1969 +++++++++++++ .../RS/Classical/Deligne/SymDatum.lean | 112 + .../RS/Classical/Deligne/SymMul.lean | 1709 +++++++++++ .../RS/Classical/Deligne/TensorDatum.lean | 233 ++ .../RS/Classical/Deligne/TensorExact.lean | 59 + .../RS/Classical/Deligne/TensorMuBraid.lean | 129 + .../RS/Classical/Deligne/TensorPowZero.lean | 94 + .../RS/Classical/Deligne/TensorTransfer.lean | 341 +++ .../RS/Classical/Deligne/TensorZigzag.lean | 989 +++++++ .../RS/Classical/Deligne/TrichotomyClose.lean | 175 ++ .../RS/Classical/Deligne/TwistBiprod.lean | 294 ++ .../RS/Classical/Deligne/TwistCoherence.lean | 137 + .../RS/Classical/Deligne/TwistDatum.lean | 159 ++ .../RS/Classical/Deligne/TwistFreeTensor.lean | 100 + .../RS/Classical/Deligne/TwistMixLine.lean | 55 + .../RS/Classical/Deligne/TwistPow.lean | 100 + .../RS/Classical/Deligne/TwistShuffle.lean | 583 ++++ .../RS/Classical/Deligne/TwistState.lean | 114 + .../RS/Classical/Deligne/TwistSymPow.lean | 51 + .../RS/Classical/Deligne/TwistUnitor.lean | 194 ++ .../RS/Classical/Deligne/UnitBase.lean | 177 ++ .../RS/Classical/Deligne/UnitFreeMod.lean | 51 + .../RS/Classical/Deligne/UnitMod.lean | 89 + .../RS/Classical/Deligne/UnitSimple.lean | 453 +++ .../RS/Classical/Deligne/UnitStage.lean | 93 + .../Classical/Deligne/UniversalAlgebra.lean | 81 + .../RS/Classical/Deligne/WhiskerFaithful.lean | 174 ++ .../RS/Classical/Deligne/WordMap.lean | 932 ++++++ .../RS/Classical/Deligne/ZagAction.lean | 118 + .../RS/Classical/Deligne/ZigzagCarrier.lean | 921 ++++++ .../RS/Classical/Deligne/ZigzagNonzero.lean | 70 + .../RS/Classical/Deligne/ZigzagSandwich.lean | 307 ++ .../RS/Classical/Deligne/ZigzagTransfer.lean | 368 +++ .../Classical/Deligne/ZigzagTransferIso.lean | 71 + .../Classical/Interfaces/DeligneBridge.lean | 74 + .../Classical/Interfaces/DelignePackage.lean | 48 + .../Interfaces/DelignePackageRestrict.lean | 41 + .../Classical/Interfaces/DeligneTheorem.lean | 46 + .../Interfaces/EulerianIndependence.lean | 116 + .../Classical/Interfaces/FibreTransport.lean | 85 + .../RS/Classical/Interfaces/KoszulAction.lean | 109 + .../RS/Classical/Interfaces/OmegaPerm.lean | 112 + .../Interfaces/OmegaTensorPower.lean | 292 ++ .../RS/Classical/Interfaces/SchurPackage.lean | 130 + .../Classical/Interfaces/SectorDischarge.lean | 324 +++ .../Interfaces/SectorIntertwine.lean | 511 ++++ .../Classical/Interfaces/TotalDimension.lean | 140 + .../RS/Classical/SchurTheory/BlockKill.lean | 49 + .../RS/Classical/SchurTheory/BranchTrace.lean | 147 + .../RS/Classical/SchurTheory/CentralElem.lean | 79 + .../RS/Classical/SchurTheory/CharClass.lean | 96 + .../RS/Classical/SchurTheory/CharDecomp.lean | 222 ++ .../RS/Classical/SchurTheory/CharEquiv.lean | 43 + .../Classical/SchurTheory/ColourCycleSum.lean | 45 + .../Classical/SchurTheory/ColourWeight.lean | 149 + .../Classical/SchurTheory/CommutantBound.lean | 234 ++ .../Classical/SchurTheory/ContentCount.lean | 248 ++ .../RS/Classical/SchurTheory/CycleFactor.lean | 65 + .../RS/Classical/SchurTheory/CycleSum.lean | 68 + .../Classical/SchurTheory/CycleSumPrep.lean | 92 + .../RS/Classical/SchurTheory/EndSum.lean | 48 + .../RS/Classical/SchurTheory/FibreCard.lean | 59 + .../RS/Classical/SchurTheory/FixWeight.lean | 164 ++ .../RS/Classical/SchurTheory/HVal.lean | 177 ++ .../SchurTheory/IdempotentBridge.lean | 53 + .../RS/Classical/SchurTheory/JTChar.lean | 149 + .../RS/Classical/SchurTheory/JTIntChar.lean | 114 + .../Classical/SchurTheory/JTIrreducible.lean | 237 ++ .../RS/Classical/SchurTheory/JTOrtho.lean | 203 ++ .../RS/Classical/SchurTheory/JTPad.lean | 491 ++++ .../RS/Classical/SchurTheory/JTSimple.lean | 30 + .../RS/Classical/SchurTheory/KillSimples.lean | 55 + .../RS/Classical/SchurTheory/MixedCount.lean | 143 + .../RS/Classical/SchurTheory/MixedFixed.lean | 144 + .../Classical/SchurTheory/NativeAction.lean | 131 + .../Classical/SchurTheory/NativeFaithful.lean | 354 +++ .../RS/Classical/SchurTheory/NativeTable.lean | 231 ++ .../RS/Classical/SchurTheory/OrbitBridge.lean | 203 ++ .../RS/Classical/SchurTheory/Package.lean | 30 + .../SchurTheory/PackageAssembly.lean | 91 + .../RS/Classical/SchurTheory/PairChar.lean | 53 + .../RS/Classical/SchurTheory/PairInner.lean | 235 ++ .../RS/Classical/SchurTheory/PairOrbit.lean | 158 ++ .../RS/Classical/SchurTheory/PairStab.lean | 71 + .../RS/Classical/SchurTheory/PairTuple.lean | 142 + .../RS/Classical/SchurTheory/PairingPos.lean | 474 ++++ .../RS/Classical/SchurTheory/PermModule.lean | 160 ++ .../RS/Classical/SchurTheory/PowerSurj.lean | 230 ++ .../Classical/SchurTheory/RegularTrace.lean | 64 + .../Classical/SchurTheory/SameCycleQuot.lean | 147 + .../RS/Classical/SchurTheory/ScalarTrace.lean | 68 + .../RS/Classical/SchurTheory/SchurAction.lean | 111 + .../Classical/SchurTheory/SigmaCycleType.lean | 107 + .../RS/Classical/SchurTheory/SignResolve.lean | 114 + .../Classical/SchurTheory/SignedTensor.lean | 123 + .../RS/Classical/SchurTheory/SimpleEmbed.lean | 70 + .../Classical/SchurTheory/SquareGrowth.lean | 150 + .../SchurTheory/SquareGrowthSharp.lean | 129 + .../RS/Classical/SchurTheory/SquareStair.lean | 150 + .../RS/Classical/SchurTheory/StabCount.lean | 112 + .../SchurTheory/TensorNonvanishing.lean | 130 + .../RS/Classical/SchurTheory/TensorTrace.lean | 50 + .../Classical/SchurTheory/WordCommutant.lean | 153 + .../RS/Classical/Super/ColourAction.lean | 61 + .../RS/Classical/Super/ColourConj.lean | 101 + .../RS/Classical/Super/ColourConjStep.lean | 104 + .../RS/Classical/Super/ColourConjTop.lean | 2376 ++++++++++++++++ .../RS/Classical/Super/ColourEval.lean | 68 + .../RS/Classical/Super/ColourExtendSwap.lean | 460 +++ .../RS/Classical/Super/ColourFormMatch.lean | 65 + .../RS/Classical/Super/ColourMerge.lean | 1157 ++++++++ .../RS/Classical/Super/ColourMergeOdd.lean | 920 ++++++ .../RS/Classical/Super/ColourPairing.lean | 61 + .../RS/Classical/Super/ColourPairingSymm.lean | 238 ++ .../RS/Classical/Super/ColourPower.lean | 324 +++ .../RS/Classical/Super/ColourTotal.lean | 90 + .../RS/Classical/Super/ColourWord.lean | 128 + .../RS/Classical/Super/OrthonormalBasis.lean | 77 + .../RS/Classical/Super/PowBraid.lean | 120 + .../RS/Classical/Super/SuperVect.lean | 185 ++ .../RS/Classical/Super/SymplecticBasis.lean | 314 +++ .../RS/Classical/Super/TotalSpace.lean | 89 + .../RS/Classical/Super/WordSignPerm.lean | 315 +++ .../RS/Classical/SymFun/AlternantExpand.lean | 78 + .../RS/Classical/SymFun/AlternantPieri.lean | 135 + .../RS/Classical/SymFun/AlternantStrict.lean | 108 + .../RS/Classical/SymFun/Bialternant.lean | 134 + .../RS/Classical/SymFun/BinomialDet.lean | 313 +++ .../RS/Classical/SymFun/BinomialH.lean | 146 + .../RS/Classical/SymFun/CoeffExtract.lean | 88 + .../RS/Classical/SymFun/CoeffSplit.lean | 116 + .../RS/Classical/SymFun/DeltaSeq.lean | 92 + .../RS/Classical/SymFun/DescVandermonde.lean | 38 + .../RS/Classical/SymFun/DimFormula.lean | 114 + .../RS/Classical/SymFun/EHConv.lean | 179 ++ .../RS/Classical/SymFun/EHDischarge.lean | 35 + .../RS/Classical/SymFun/HInsert.lean | 108 + .../RS/Classical/SymFun/HProdCoeff.lean | 95 + .../RS/Classical/SymFun/HSubZ.lean | 105 + .../RS/Classical/SymFun/HookVanishing.lean | 67 + .../RS/Classical/SymFun/JTDetExpand.lean | 85 + .../RS/Classical/SymFun/JTGuard.lean | 80 + .../RS/Classical/SymFun/LGVStrict.lean | 780 +++++ .../RS/Classical/SymFun/PieriChain.lean | 198 ++ .../RS/Classical/SymFun/PowCount.lean | 76 + .../RS/Classical/SymFun/PowerSums.lean | 71 + .../SymFun/RationalityFromRecurrence.lean | 512 ++++ .../SymFun/RecurrenceFromVanishing.lean | 295 ++ .../RS/Classical/SymFun/SubsetEH.lean | 92 + .../RS/Classical/SymFun/SuperPowerSums.lean | 214 ++ .../RS/Classical/SymFun/TCount.lean | 76 + .../RS/Classical/SymFun/TIdentity.lean | 61 + .../RS/Classical/SymFun/ZetaExp.lean | 70 + .../RS/Classical/SymFun/ZetaRational.lean | 107 + .../RS/Classical/SymFun/ZetaSeries.lean | 83 + LeanPool/RegtsSevenster/RS/Common.lean | 24 + .../RS/Common/DiagramChain.lean | 77 + .../RS/Common/ExponentialGrowth.lean | 104 + .../RS/Common/FactorialBound.lean | 141 + .../RegtsSevenster/RS/Common/FinSlots.lean | 26 + .../RegtsSevenster/RS/Common/ListAttach.lean | 42 + .../RegtsSevenster/RS/Common/ListPairs.lean | 95 + .../RegtsSevenster/RS/Common/ListSign.lean | 127 + .../RegtsSevenster/RS/Common/MathlibDeps.lean | 137 + .../RS/Common/NilpotentMap.lean | 32 + .../RS/Common/NilpotentPowerTrace.lean | 64 + .../RS/Common/PairDisjoint.lean | 46 + .../RegtsSevenster/RS/Common/PermCongr.lean | 170 ++ .../RS/Common/PermTopSplit.lean | 459 +++ .../RegtsSevenster/RS/Common/ProdSum.lean | 89 + .../RegtsSevenster/RS/Common/RowLenChain.lean | 107 + .../RegtsSevenster/RS/Common/RowSpanRank.lean | 234 ++ .../RS/Common/TraceSeparation.lean | 50 + .../RS/Common/YoungDiagrams.lean | 146 + LeanPool/RegtsSevenster/RS/Definitions.lean | 2504 +++++++++++++++++ .../RS/DimensionDefinitions.lean | 51 + LeanPool/RegtsSevenster/RS/Glossary.lean | 216 ++ LeanPool/RegtsSevenster/RS/Novel.lean | 339 +++ .../RS/Novel/Coordinates/AdjSwapBmc.lean | 139 + .../RS/Novel/Coordinates/AdjacentWord.lean | 188 ++ .../RS/Novel/Coordinates/BasisCoord.lean | 61 + .../RS/Novel/Coordinates/BasisSplit.lean | 191 ++ .../RS/Novel/Coordinates/BetaData.lean | 156 + .../RS/Novel/Coordinates/BetaDiag.lean | 149 + .../RS/Novel/Coordinates/BetaDiagForm.lean | 537 ++++ .../RS/Novel/Coordinates/BetaFlip.lean | 70 + .../RS/Novel/Coordinates/BlockAlign.lean | 123 + .../RS/Novel/Coordinates/BlockCanon.lean | 291 ++ .../RS/Novel/Coordinates/BlockData.lean | 343 +++ .../RS/Novel/Coordinates/BlockOddList.lean | 101 + .../RS/Novel/Coordinates/BlockParity.lean | 251 ++ .../RS/Novel/Coordinates/BlockRestrict.lean | 83 + .../RS/Novel/Coordinates/BlockSigma.lean | 121 + .../RS/Novel/Coordinates/BlockSort.lean | 153 + .../RS/Novel/Coordinates/BraidWord.lean | 136 + .../RS/Novel/Coordinates/CanonColour.lean | 55 + .../RS/Novel/Coordinates/CanonPerm.lean | 722 +++++ .../RS/Novel/Coordinates/CapClosed.lean | 157 ++ .../RS/Novel/Coordinates/CapExpansion.lean | 40 + .../RS/Novel/Coordinates/CapFun.lean | 65 + .../RS/Novel/Coordinates/CapMatch.lean | 37 + .../RS/Novel/Coordinates/CapPeel.lean | 419 +++ .../RS/Novel/Coordinates/CapPeelSplit.lean | 194 ++ .../RS/Novel/Coordinates/CapPerm.lean | 74 + .../RS/Novel/Coordinates/CapSplit.lean | 76 + .../RS/Novel/Coordinates/CapVal.lean | 86 + .../RS/Novel/Coordinates/ChainLists.lean | 139 + .../RS/Novel/Coordinates/CircleModel.lean | 190 ++ .../RS/Novel/Coordinates/CircleScalar.lean | 173 ++ .../RS/Novel/Coordinates/CircuitCount.lean | 266 ++ .../Novel/Coordinates/ClosedTransition.lean | 37 + .../RS/Novel/Coordinates/ConcatSign.lean | 220 ++ .../RS/Novel/Coordinates/CoordInterface.lean | 92 + .../RS/Novel/Coordinates/CoordOf.lean | 119 + .../RS/Novel/Coordinates/CoreParity.lean | 355 +++ .../RS/Novel/Coordinates/EdgeSign.lean | 128 + .../RS/Novel/Coordinates/EvForm.lean | 63 + .../RS/Novel/Coordinates/EvFormOdd.lean | 66 + .../RS/Novel/Coordinates/EvLeaf.lean | 219 ++ .../RS/Novel/Coordinates/FibreParam.lean | 609 ++++ .../RS/Novel/Coordinates/FlagEnum.lean | 241 ++ .../RS/Novel/Coordinates/GlobalSlotList.lean | 525 ++++ .../RS/Novel/Coordinates/HRS.lean | 61 + .../RS/Novel/Coordinates/IndexPerm.lean | 172 ++ .../RS/Novel/Coordinates/ListSignPerm.lean | 170 ++ .../RS/Novel/Coordinates/MasterSum.lean | 73 + .../RS/Novel/Coordinates/ModelCoord.lean | 158 ++ .../RS/Novel/Coordinates/ModelPermCoord.lean | 105 + .../RS/Novel/Coordinates/ModelStarVec.lean | 142 + .../RS/Novel/Coordinates/MultiStar.lean | 94 + .../RS/Novel/Coordinates/NFDef.lean | 159 ++ .../RS/Novel/Coordinates/NFValue.lean | 261 ++ .../RS/Novel/Coordinates/OddFlip.lean | 96 + .../RS/Novel/Coordinates/OddListMultiset.lean | 275 ++ .../RS/Novel/Coordinates/OddPair.lean | 120 + .../RS/Novel/Coordinates/OddSignProd.lean | 154 + .../RS/Novel/Coordinates/OmegaCotensor.lean | 147 + .../RS/Novel/Coordinates/OmegaStarVec.lean | 109 + .../RS/Novel/Coordinates/OmegaTensor.lean | 158 ++ .../RS/Novel/Coordinates/OmegaTransport.lean | 108 + .../RS/Novel/Coordinates/OneBasis.lean | 274 ++ .../RS/Novel/Coordinates/OrbitCard.lean | 214 ++ .../RS/Novel/Coordinates/OutSignEdges.lean | 116 + .../RS/Novel/Coordinates/PairEnum.lean | 107 + .../RS/Novel/Coordinates/PairList.lean | 257 ++ .../RS/Novel/Coordinates/ParameterModel.lean | 152 + .../RS/Novel/Coordinates/PatternInv.lean | 63 + .../RS/Novel/Coordinates/PowMerge.lean | 188 ++ .../RS/Novel/Coordinates/RegroupSign.lean | 1145 ++++++++ .../RS/Novel/Coordinates/Reindex.lean | 127 + .../RS/Novel/Coordinates/ReindexBij.lean | 241 ++ .../RS/Novel/Coordinates/ReindexHeart.lean | 314 +++ .../RS/Novel/Coordinates/ReindexVanish.lean | 158 ++ .../RS/Novel/Coordinates/RepFlag.lean | 88 + .../RS/Novel/Coordinates/RiffleSign.lean | 672 +++++ .../RS/Novel/Coordinates/SignPair.lean | 58 + .../RS/Novel/Coordinates/SkeinPowBraid.lean | 205 ++ .../RS/Novel/Coordinates/SlotPairing.lean | 44 + .../RS/Novel/Coordinates/SortFactor.lean | 99 + .../RS/Novel/Coordinates/SortPerm.lean | 50 + .../RS/Novel/Coordinates/StarClassFactor.lean | 110 + .../RS/Novel/Coordinates/StarPeel.lean | 392 +++ .../RS/Novel/Coordinates/StarPerm.lean | 119 + .../RS/Novel/Coordinates/StarRepeat.lean | 297 ++ .../RS/Novel/Coordinates/StarSymm.lean | 56 + .../RS/Novel/Coordinates/StarTensorClass.lean | 71 + .../RS/Novel/Coordinates/StdTransport.lean | 136 + .../RS/Novel/Coordinates/StrandTransport.lean | 116 + .../RS/Novel/Coordinates/TauCount.lean | 77 + .../RS/Novel/Coordinates/TauKey.lean | 113 + .../RS/Novel/Coordinates/TopBraidMerge.lean | 145 + .../RS/Novel/Coordinates/TwoBasis.lean | 107 + .../RS/Novel/Coordinates/VertexSign.lean | 132 + .../RS/Novel/Coordinates/VertexValue.lean | 206 ++ .../RS/Novel/Envelope/AtomDichotomy.lean | 164 ++ .../RS/Novel/Envelope/AtomicIdempotents.lean | 189 ++ .../RS/Novel/Envelope/BlockAssembly.lean | 94 + .../RS/Novel/Envelope/BlockBounds.lean | 72 + .../RS/Novel/Envelope/BlockCycle.lean | 459 +++ .../RS/Novel/Envelope/BlockFactor.lean | 966 +++++++ .../Novel/Envelope/BlockFactorialTrace.lean | 61 + .../RS/Novel/Envelope/BlockSplice.lean | 940 +++++++ .../RS/Novel/Envelope/BlockTower.lean | 317 +++ .../RS/Novel/Envelope/CycleNormal.lean | 119 + .../RS/Novel/Envelope/CycleTrace.lean | 181 ++ .../RS/Novel/Envelope/EnvAbelian.lean | 311 ++ .../RS/Novel/Envelope/EnvDeligne.lean | 113 + .../RS/Novel/Envelope/EnvDelignePackage.lean | 97 + .../RS/Novel/Envelope/EnvGenerator.lean | 280 ++ .../RS/Novel/Envelope/EnvGrowth.lean | 177 ++ .../RS/Novel/Envelope/EnvInstances.lean | 278 ++ .../RS/Novel/Envelope/EnvSemisimple.lean | 239 ++ .../RS/Novel/Envelope/FactorialTrace.lean | 88 + .../RS/Novel/Envelope/Frobenius.lean | 108 + .../RS/Novel/Envelope/HookConfinement.lean | 131 + .../Novel/Envelope/HookConfinementSharp.lean | 72 + .../RS/Novel/Envelope/KaroubiEmbBraided.lean | 69 + .../RS/Novel/Envelope/KaroubiMonoidal.lean | 839 ++++++ .../RS/Novel/Envelope/KaroubiRigid.lean | 317 +++ .../RS/Novel/Envelope/KaroubiSemisimple.lean | 120 + .../RS/Novel/Envelope/MatBraided.lean | 468 +++ .../RS/Novel/Envelope/MatEmbMonoidal.lean | 504 ++++ .../RS/Novel/Envelope/MatMonoidal.lean | 541 ++++ .../RS/Novel/Envelope/MatRigid.lean | 407 +++ .../RS/Novel/Envelope/MatSemisimple.lean | 252 ++ .../RS/Novel/Envelope/NilpotentMatTrace.lean | 762 +++++ .../RS/Novel/Envelope/NilpotentTrace.lean | 114 + .../RS/Novel/Envelope/ObjectTower.lean | 180 ++ .../RS/Novel/Envelope/PermTrace.lean | 199 ++ .../RS/Novel/Envelope/RankDimension.lean | 52 + .../RS/Novel/Envelope/ScalarPermTrace.lean | 52 + .../RS/Novel/Envelope/ScalarTrace.lean | 68 + .../RS/Novel/Envelope/SemisimpleAll.lean | 52 + .../RS/Novel/Envelope/SemisimpleEnd.lean | 14 + .../RS/Novel/Envelope/SkeinDimBound.lean | 94 + .../RS/Novel/Envelope/SkeinTower.lean | 292 ++ .../RS/Novel/Envelope/SkeinTrace.lean | 83 + .../RS/Novel/Envelope/SuperKill.lean | 45 + .../RS/Novel/Envelope/SymPerm.lean | 672 +++++ .../RS/Novel/Envelope/SymPermCast.lean | 142 + .../RS/Novel/Envelope/TensorPowHom.lean | 149 + .../RS/Novel/Envelope/TensorPowSplit.lean | 444 +++ .../RS/Novel/Envelope/TraceZeta.lean | 99 + .../RS/Novel/Envelope/TraceZetaSharp.lean | 111 + .../RS/Novel/Extraction/CircleValue.lean | 52 + .../RS/Novel/Extraction/CoordIso.lean | 138 + .../RS/Novel/Extraction/Coordinates.lean | 250 ++ .../RS/Novel/Extraction/CopairUnique.lean | 281 ++ .../RS/Novel/Extraction/Nondegenerate.lean | 309 ++ .../RS/Novel/Extraction/SnakeTransport.lean | 107 + .../RS/Novel/Extraction/StdDuality.lean | 106 + .../RS/Novel/Extraction/StdRigid.lean | 286 ++ .../RS/Novel/Extraction/StdSuper.lean | 197 ++ .../RS/Novel/Skein/AllInternalAgreement.lean | 354 +++ .../Novel/Skein/AllInternalIndependence.lean | 128 + .../RS/Novel/Skein/BraidedInstance.lean | 383 +++ .../RS/Novel/Skein/BraidedNat.lean | 359 +++ .../RS/Novel/Skein/BundleClose.lean | 585 ++++ .../RS/Novel/Skein/BundleMapClasses.lean | 338 +++ .../RS/Novel/Skein/BundleTensor.lean | 132 + .../RS/Novel/Skein/CanonExistence.lean | 356 +++ .../RS/Novel/Skein/CanonTransport.lean | 140 + .../RS/Novel/Skein/CanonicalFrame.lean | 573 ++++ .../RS/Novel/Skein/ChainAgreement.lean | 319 +++ .../RS/Novel/Skein/ChordCount.lean | 111 + .../RS/Novel/Skein/ChordLabels.lean | 123 + .../RS/Novel/Skein/ChordParity.lean | 32 + .../RS/Novel/Skein/ChordSwapParity.lean | 48 + .../RS/Novel/Skein/CloseRotate.lean | 1554 ++++++++++ .../RS/Novel/Skein/CloseRotateLeft.lean | 1466 ++++++++++ .../RS/Novel/Skein/CloseUnion.lean | 282 ++ .../RS/Novel/Skein/ClosedAgreement.lean | 255 ++ .../RS/Novel/Skein/ClosedCutDispatch.lean | 272 ++ .../RS/Novel/Skein/ClosedIdentify.lean | 211 ++ .../RS/Novel/Skein/ClosedTopSum.lean | 105 + .../RS/Novel/Skein/ColourEmbedding.lean | 175 ++ .../RS/Novel/Skein/ColourGlue.lean | 1970 +++++++++++++ .../RS/Novel/Skein/ColourPadding.lean | 259 ++ .../RS/Novel/Skein/ColourRecursion.lean | 896 ++++++ .../RS/Novel/Skein/ComposeAssoc.lean | 1192 ++++++++ .../RS/Novel/Skein/ComposeNormal.lean | 596 ++++ .../RS/Novel/Skein/ComposeRelabel.lean | 248 ++ .../RS/Novel/Skein/Composition.lean | 103 + .../RS/Novel/Skein/CompositionEquiv.lean | 41 + .../RS/Novel/Skein/ConnectionRank.lean | 57 + .../RS/Novel/Skein/ConverseAssembly.lean | 2026 +++++++++++++ .../RS/Novel/Skein/ConverseDischarge.lean | 28 + .../RS/Novel/Skein/ConverseFamily.lean | 2343 +++++++++++++++ .../RS/Novel/Skein/ConverseGram.lean | 82 + .../RS/Novel/Skein/ConverseIdentity.lean | 151 + .../RS/Novel/Skein/ConverseLift.lean | 724 +++++ .../RS/Novel/Skein/ConversePair.lean | 1087 +++++++ .../RS/Novel/Skein/ConverseTrip.lean | 1617 +++++++++++ .../RS/Novel/Skein/CrossingDelta.lean | 714 +++++ .../RS/Novel/Skein/CutMatching.lean | 955 +++++++ .../RS/Novel/Skein/CutSubsetSum.lean | 168 ++ .../RS/Novel/Skein/DirMatching.lean | 2220 +++++++++++++++ .../RS/Novel/Skein/DisjSubsetSplit.lean | 259 ++ .../RS/Novel/Skein/DisjUnionFactor.lean | 14 + .../RS/Novel/Skein/DisjUnionFactor/A.lean | 762 +++++ .../RS/Novel/Skein/DisjUnionFactor/B.lean | 735 +++++ .../RS/Novel/Skein/DisjUnionFactor/C.lean | 144 + .../RS/Novel/Skein/DisjUnionProduct.lean | 1038 +++++++ .../RS/Novel/Skein/EdgeColouring.lean | 432 +++ .../RS/Novel/Skein/EdgeSum.lean | 93 + .../RS/Novel/Skein/EdgeTerm.lean | 1323 +++++++++ .../RS/Novel/Skein/Eulerian.lean | 215 ++ .../RS/Novel/Skein/ExactPairingInstance.lean | 119 + .../RS/Novel/Skein/FibreValue.lean | 65 + .../RS/Novel/Skein/FlagGraph.lean | 74 + .../RS/Novel/Skein/FlipSignForm.lean | 218 ++ .../RS/Novel/Skein/FlipSignProduct.lean | 74 + .../RS/Novel/Skein/FourLabelParity.lean | 121 + .../RS/Novel/Skein/FragmentEquiv.lean | 383 +++ .../RS/Novel/Skein/GenBoundaryStates.lean | 82 + .../RS/Novel/Skein/GlueAmbient.lean | 533 ++++ .../RS/Novel/Skein/GlueChord.lean | 685 +++++ .../RS/Novel/Skein/GlueChords.lean | 119 + .../RS/Novel/Skein/GlueCircuitDelta.lean | 1339 +++++++++ .../RS/Novel/Skein/GlueComm.lean | 2169 ++++++++++++++ .../RS/Novel/Skein/GlueCrossDelta.lean | 378 +++ .../RS/Novel/Skein/GlueFold.lean | 2310 +++++++++++++++ .../RS/Novel/Skein/GlueLedger.lean | 658 +++++ .../RS/Novel/Skein/GluePathMatch.lean | 857 ++++++ .../RS/Novel/Skein/GlueRelTransport.lean | 1249 ++++++++ .../RS/Novel/Skein/GlueSplit.lean | 38 + .../RS/Novel/Skein/GlueSplitProof.lean | 14 + .../RS/Novel/Skein/GlueSplitProof/A.lean | 465 +++ .../RS/Novel/Skein/GlueSplitProof/C.lean | 683 +++++ .../RS/Novel/Skein/GlueSubsetBij.lean | 567 ++++ .../RS/Novel/Skein/GramRank.lean | 106 + .../RS/Novel/Skein/HomCompose.lean | 106 + .../RS/Novel/Skein/HomSpaces.lean | 56 + .../RS/Novel/Skein/HomTensor.lean | 110 + .../RS/Novel/Skein/HomTraceCyclic.lean | 59 + .../RS/Novel/Skein/HomTraceNondegenerate.lean | 42 + .../RS/Novel/Skein/IdentityLaw.lean | 1070 +++++++ .../RS/Novel/Skein/IdentityLawRight.lean | 844 ++++++ .../RS/Novel/Skein/InterfaceAlternate.lean | 1149 ++++++++ .../RS/Novel/Skein/InterfaceContract.lean | 279 ++ .../RS/Novel/Skein/InterfaceCut.lean | 684 +++++ .../RS/Novel/Skein/InterfaceOrderIso.lean | 272 ++ .../RS/Novel/Skein/InterfaceShift.lean | 447 +++ .../RS/Novel/Skein/InvolutionCard.lean | 78 + .../RS/Novel/Skein/LabelChords.lean | 146 + .../RS/Novel/Skein/LedgerCast.lean | 73 + .../RS/Novel/Skein/LedgerRecursion.lean | 726 +++++ .../RS/Novel/Skein/LedgerSets.lean | 306 ++ .../RS/Novel/Skein/LedgerStage.lean | 433 +++ .../RS/Novel/Skein/LedgerValue.lean | 80 + .../RS/Novel/Skein/LoopExample.lean | 488 ++++ .../RS/Novel/Skein/LoopVerify.lean | 144 + .../RS/Novel/Skein/MixedPartition.lean | 530 ++++ .../RS/Novel/Skein/MonoidalInstance.lean | 122 + .../RS/Novel/Skein/MonoidalNat.lean | 278 ++ .../RS/Novel/Skein/MonoidalStruct.lean | 185 ++ .../RS/Novel/Skein/Multiplicativity.lean | 186 ++ .../RS/Novel/Skein/NonSeparatedStep.lean | 1868 ++++++++++++ .../RS/Novel/Skein/OpenCircuits.lean | 514 ++++ .../RS/Novel/Skein/OrbitParities.lean | 397 +++ .../RS/Novel/Skein/OrientExistence.lean | 497 ++++ .../RS/Novel/Skein/OrientationFlip.lean | 881 ++++++ .../RS/Novel/Skein/PairCloseComm.lean | 213 ++ .../RS/Novel/Skein/PairedAssembly.lean | 2126 ++++++++++++++ .../RS/Novel/Skein/PairingConnectivity.lean | 254 ++ .../RS/Novel/Skein/PairingSignature.lean | 57 + .../RS/Novel/Skein/PairingSwap.lean | 287 ++ .../RS/Novel/Skein/PairingValue.lean | 109 + .../RS/Novel/Skein/PartialClose.lean | 211 ++ .../RS/Novel/Skein/PartialCloseCompose.lean | 402 +++ .../RS/Novel/Skein/PartialCloseTensor.lean | 536 ++++ .../RS/Novel/Skein/PathCanon.lean | 176 ++ .../RS/Novel/Skein/PathLedger.lean | 1046 +++++++ .../RS/Novel/Skein/PathMatch.lean | 521 ++++ .../RS/Novel/Skein/PermCompose.lean | 143 + .../RS/Novel/Skein/PermFragment.lean | 158 ++ .../RS/Novel/Skein/PropThreeOpen.lean | 51 + .../RS/Novel/Skein/RSTensor.lean | 1839 ++++++++++++ .../RS/Novel/Skein/RelTransition.lean | 353 +++ .../RS/Novel/Skein/RelValue.lean | 86 + .../RS/Novel/Skein/RelabelChords.lean | 39 + .../RS/Novel/Skein/RelabelInvariance.lean | 617 ++++ .../RS/Novel/Skein/RepairInvariance.lean | 918 ++++++ .../RS/Novel/Skein/RigidInstance.lean | 59 + .../RS/Novel/Skein/RigidityClasses.lean | 90 + .../RS/Novel/Skein/ScalarClass.lean | 63 + .../RS/Novel/Skein/ScalarFunctional.lean | 46 + .../RS/Novel/Skein/SeparatedParity.lean | 1802 ++++++++++++ .../RS/Novel/Skein/SimpleUnit.lean | 76 + .../RS/Novel/Skein/SkeinCatInstance.lean | 40 + .../RS/Novel/Skein/SkeinCategory.lean | 237 ++ .../RS/Novel/Skein/SkeinIdeal.lean | 136 + .../RS/Novel/Skein/SkeinIdealLeft.lean | 109 + .../RS/Novel/Skein/SkeinLinear.lean | 66 + .../RS/Novel/Skein/SnakeClasses.lean | 178 ++ .../RS/Novel/Skein/StarCompClass.lean | 59 + .../RS/Novel/Skein/StarDecomposition.lean | 447 +++ .../RS/Novel/Skein/StarEnum.lean | 314 +++ .../RS/Novel/Skein/StarExplode.lean | 393 +++ .../RS/Novel/Skein/StarPrep.lean | 223 ++ .../RS/Novel/Skein/StarTrace.lean | 38 + .../RS/Novel/Skein/StateFlipSet.lean | 127 + .../RS/Novel/Skein/StatusSet.lean | 133 + .../RS/Novel/Skein/StepFrame.lean | 559 ++++ .../RS/Novel/Skein/StepLedger.lean | 727 +++++ .../RS/Novel/Skein/StepStatus.lean | 451 +++ .../RS/Novel/Skein/StepStatusNonsep.lean | 414 +++ .../RS/Novel/Skein/StrandBundle.lean | 72 + .../RS/Novel/Skein/SumLexOrder.lean | 68 + .../RS/Novel/Skein/SuperGram.lean | 583 ++++ .../RS/Novel/Skein/SuperSpace.lean | 131 + .../RS/Novel/Skein/TensorAssoc.lean | 144 + .../RS/Novel/Skein/TensorComm.lean | 139 + .../RS/Novel/Skein/TensorCompClass.lean | 206 ++ .../RS/Novel/Skein/TensorFragment.lean | 117 + .../RS/Novel/Skein/TensorIdeal.lean | 1124 ++++++++ .../RS/Novel/Skein/TensorInterchange.lean | 730 +++++ .../RS/Novel/Skein/TensorUnit.lean | 115 + .../RS/Novel/Skein/ThroughEdgeCut.lean | 167 ++ .../RS/Novel/Skein/ThroughIndCFalse.lean | 96 + .../RS/Novel/Skein/ThroughValue.lean | 226 ++ .../RegtsSevenster/RS/Novel/Skein/Trace.lean | 62 + .../RS/Novel/Skein/TraceCyclic.lean | 187 ++ .../RS/Novel/Skein/TraceNondegenerate.lean | 96 + .../RS/Novel/Skein/TransitionExists.lean | 494 ++++ .../RS/Novel/Skein/TransitionMove.lean | 640 +++++ .../RS/Novel/Skein/TransposeLedger.lean | 810 ++++++ .../RS/Novel/Skein/TwoPathNonSep.lean | 1594 +++++++++++ .../RS/Novel/Skein/TwoPathStep.lean | 461 +++ .../RS/Novel/Skein/VertexOddSign.lean | 200 ++ .../RS/Novel/Skein/VertexSum.lean | 66 + LeanPool/RegtsSevenster/RS/QuantSector.lean | 75 + .../RegtsSevenster/RS/StatementConverse.lean | 137 + LeanPool/RegtsSevenster/RS/Summit.lean | 100 + .../RegtsSevenster/RS/TheoremConverse.lean | 91 + .../RegtsSevenster/RS/TheoremDimension.lean | 115 + .../RegtsSevenster/RS/TheoremForward.lean | 38 + .../RegtsSevenster/RS/TheoremPadding.lean | 90 + LeanPool/RegtsSevenster/RS/TheoremQuant.lean | 40 + LeanPool/RegtsSevenster/RS/TheoremTotal.lean | 43 + LeanPool/RegtsSevenster/Solution.lean | 72 + LeanPool/projects.yml | 49 + 840 files changed, 272369 insertions(+) create mode 100644 LeanPool/RegtsSevenster.lean create mode 100644 LeanPool/RegtsSevenster/RS.lean create mode 100644 LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean create mode 100644 LeanPool/RegtsSevenster/RS/Assembly/BlueprintConverse.lean create mode 100644 LeanPool/RegtsSevenster/RS/Assembly/BlueprintDeligne.lean create mode 100644 LeanPool/RegtsSevenster/RS/Assembly/BlueprintFactorial.lean create mode 100644 LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean create mode 100644 LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Algebra/FactorialTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Algebra/TraceCriterion.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/CatTheory/Growth.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/CatTheory/Intertwine.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiLinear.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/CatTheory/Length.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/CatTheory/LengthBound.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/CatTheory/LinearCategory.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/CatTheory/PartialTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/CatTheory/TensorPow.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/CatTheory/Trace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/CatTheory/UnitEnd.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/CatTheory/WhiskerAdditive.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPow.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPowAct.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeBiprod.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeDatum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeFree.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeLinear.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeMonoidal.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTensor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTransport.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeZigzag.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensorUnit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodPow.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodTransfer.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/BlockUnits.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/BraidCoherence.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainAlgebra.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainB.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGradedLaws.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBInd.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBNonzero.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBofA.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBridge.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainDelta.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/Base.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/FirstSlot.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/SecondSlot.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMul.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulHet.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulLaws.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainNonzero.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainShift.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainStage2.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainUnit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/CharSplit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/CommonAlgebra.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/CoprodPreserve.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescent.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescentClose.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableNullstellensatz.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/CoverFactor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/CycleSplit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/DayCalculus.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/DayType.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/DeligneAssembly.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/DescentClose.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/DevissageBound.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledAbelian.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledGrowth.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledLine.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledScalar.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSmall.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSplit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/Doubling.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/DualityMate.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/EvenEmbedMonoidal.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ExactFromShort.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FactorialBeats.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreAdditive.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreBridge.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreEps.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreExact.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFaithful.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFunctor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreLinear.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMix.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMonoidal.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMu.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMuNat.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverComplex.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverSplitting.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreRestrict.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreStrong.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FiltNil.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FlatLimit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeCollapseAlg.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeMixRetract.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModAdjoint.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModBiprod.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModFunctor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffle.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffleCoh.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModTensor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormalise.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseBase.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseStep.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePow.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowDesc.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowInsert.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSlide.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSummand.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeTwistPi.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaAlgebra.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaBiprod.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaComplex.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaCountable.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModule.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModuleFunctor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPair.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairAdd.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeFree.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeMix.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairNat.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetract.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetractRight.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairUnit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaShift.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaTwistLeft.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GeneratorAlgebra.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/GrowthDichotomy.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/HomFinite.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/HookMult.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/HookZero.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IdempotentLength.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ImageSubalgebra.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndAllColim.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndBigTensorUnit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCoeq.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCompact.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndDayClosure.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndImage.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndLocallyMixed.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndMonoidal.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfLinear.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfMonoidal.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndPointTensor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchur.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSimple.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplitSection.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/IndUnitNonzero.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/InitDatum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/InitState.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/KernelPow.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemma.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaClose.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaData.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/KillerNonempty.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/LambdaCoend.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffle.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffleLine.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/MixSumPow.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhisker.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhiskerAll.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedConc.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedDiag.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedTransport.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAbelian.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAssoc.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ModBiprod.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ModContractL.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ModCross.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ModDual.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMulti.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMultiTriple.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowCast.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescent.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescentClose.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowStage.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchur.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchurSummand.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ModZero.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/MuInterchange.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/MulBy.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/NatChain.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/NewtonConv.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/NullPoint.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLineMap.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLinePairing.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/OddParity.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/OddPermSign.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquare.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquareIso.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PairCarrier.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PairMul.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PairPerm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PermNat.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PermRepChar.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PieriPos.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PlainShuffle.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PointBaseChange.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PointFibre.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Calculus.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Comparison.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Functor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PointTensor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PowAct.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PowActMul.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PowChain.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PowCopairing.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PowDatum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PowInduct.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PowMerge.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairSucc.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPoint.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSucc.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSuccMod.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PowTriangle.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZig.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZigzag.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/PresentedQuotient.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21Core.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21General.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29Close.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29State.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Bridge.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Chain.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Close.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Ind.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Reduce.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoBiprod.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoTwist.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/RowColIdem.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichMerge.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichRetract.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichZig.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarBraiding.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarLinear.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitEquiv.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitInd.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurVanishing.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeAlgebra.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeFintype.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SignConj.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleGenerator.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SimplePoint.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleQuotient.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleScalars.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SmallReduction.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAdjoint.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitClosure.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitComplement.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitEverything.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExact.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtract.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtractDual.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitPairDef.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitReduce.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitTransport.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SplittingAlgebra.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/StateTransport.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/StepA.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/StepATransport.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/StepB.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Letters.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Signs.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEvenRing.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGamma.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModAbelian.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprod.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprodMap.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModHom.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModIso.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModMonoidal.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShift.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShiftUnit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModTensor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperPointMod.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSeries.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSmall.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperValues.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SymAlg.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SymDatum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorDatum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorExact.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorMuBraid.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorPowZero.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorTransfer.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorZigzag.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/TrichotomyClose.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistBiprod.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistCoherence.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistDatum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistFreeTensor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistMixLine.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistPow.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistShuffle.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistState.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistSymPow.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistUnitor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitBase.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitFreeMod.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitMod.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitSimple.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitStage.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/UniversalAlgebra.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/WhiskerFaithful.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/WordMap.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ZagAction.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagCarrier.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagNonzero.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagSandwich.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransfer.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransferIso.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneBridge.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackage.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackageRestrict.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneTheorem.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Interfaces/EulerianIndependence.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Interfaces/FibreTransport.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Interfaces/KoszulAction.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaPerm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaTensorPower.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Interfaces/SchurPackage.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorDischarge.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorIntertwine.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Interfaces/TotalDimension.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BlockKill.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BranchTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CentralElem.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharClass.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharDecomp.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharEquiv.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourCycleSum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourWeight.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CommutantBound.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ContentCount.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleFactor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSumPrep.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/EndSum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FibreCard.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FixWeight.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/HVal.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/IdempotentBridge.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTChar.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIntChar.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIrreducible.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTOrtho.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTSimple.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/KillSimples.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedCount.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedFixed.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeAction.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeFaithful.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeTable.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/OrbitBridge.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/Package.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PackageAssembly.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairChar.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairInner.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairOrbit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairStab.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairTuple.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PermModule.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PowerSurj.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/RegularTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SameCycleQuot.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ScalarTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SchurAction.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SigmaCycleType.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignResolve.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowth.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowthSharp.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareStair.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/StabCount.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorNonvanishing.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SchurTheory/WordCommutant.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/ColourAction.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/ColourConj.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjStep.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/ColourEval.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/ColourExtendSwap.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/ColourFormMatch.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/ColourMerge.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairing.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairingSymm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/ColourPower.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/ColourTotal.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/ColourWord.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/OrthonormalBasis.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/PowBraid.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/SuperVect.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/SymplecticBasis.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/TotalSpace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/Super/WordSignPerm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantExpand.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantPieri.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantStrict.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/Bialternant.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialDet.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialH.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffExtract.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffSplit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/DeltaSeq.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/DescVandermonde.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/DimFormula.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/EHConv.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/EHDischarge.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/HInsert.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/HProdCoeff.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/HSubZ.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/HookVanishing.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/JTDetExpand.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/JTGuard.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/LGVStrict.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/PieriChain.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/PowCount.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/PowerSums.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/RationalityFromRecurrence.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/RecurrenceFromVanishing.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/SubsetEH.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/SuperPowerSums.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/TCount.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/TIdentity.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaExp.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaRational.lean create mode 100644 LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaSeries.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/DiagramChain.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/ExponentialGrowth.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/FactorialBound.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/FinSlots.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/ListAttach.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/ListPairs.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/ListSign.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/MathlibDeps.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/NilpotentMap.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/NilpotentPowerTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/PairDisjoint.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/PermCongr.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/PermTopSplit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/ProdSum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/RowLenChain.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/RowSpanRank.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/TraceSeparation.lean create mode 100644 LeanPool/RegtsSevenster/RS/Common/YoungDiagrams.lean create mode 100644 LeanPool/RegtsSevenster/RS/Definitions.lean create mode 100644 LeanPool/RegtsSevenster/RS/DimensionDefinitions.lean create mode 100644 LeanPool/RegtsSevenster/RS/Glossary.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjSwapBmc.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjacentWord.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisCoord.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisSplit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaData.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiag.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiagForm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaFlip.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockAlign.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockCanon.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockData.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockOddList.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockParity.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockRestrict.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSigma.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSort.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/BraidWord.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonColour.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapClosed.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapExpansion.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapFun.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapMatch.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeel.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeelSplit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPerm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapSplit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapVal.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/ChainLists.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleModel.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleScalar.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircuitCount.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/ClosedTransition.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/ConcatSign.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordInterface.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordOf.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoreParity.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/EdgeSign.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvForm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvFormOdd.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvLeaf.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/FibreParam.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/FlagEnum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/GlobalSlotList.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/HRS.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/IndexPerm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/ListSignPerm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/MasterSum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelCoord.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelPermCoord.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelStarVec.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/MultiStar.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFDef.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFValue.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddFlip.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddListMultiset.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddPair.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaCotensor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaStarVec.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTransport.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/OneBasis.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/OrbitCard.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/OutSignEdges.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairEnum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairList.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/ParameterModel.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/PatternInv.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/PowMerge.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/Reindex.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexBij.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexHeart.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexVanish.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/RepFlag.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/RiffleSign.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/SignPair.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/SkeinPowBraid.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/SlotPairing.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortFactor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortPerm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarClassFactor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPeel.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPerm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarRepeat.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarSymm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarTensorClass.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/StdTransport.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/StrandTransport.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauCount.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauKey.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/TopBraidMerge.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/TwoBasis.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexSign.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexValue.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomDichotomy.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomicIdempotents.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockAssembly.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockBounds.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactorialTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockSplice.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockTower.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleNormal.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvAbelian.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDeligne.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDelignePackage.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGenerator.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGrowth.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvInstances.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvSemisimple.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/FactorialTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/Frobenius.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinement.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinementSharp.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiEmbBraided.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiMonoidal.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiRigid.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiSemisimple.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/MatSemisimple.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentMatTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/ObjectTower.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/PermTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/RankDimension.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarPermTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleAll.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleEnd.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinDimBound.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTower.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/SuperKill.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPerm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPermCast.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowHom.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowSplit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZeta.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZetaSharp.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Extraction/CircleValue.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Extraction/CoordIso.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Extraction/Coordinates.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Extraction/CopairUnique.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Extraction/Nondegenerate.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Extraction/SnakeTransport.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Extraction/StdDuality.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Extraction/StdSuper.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalAgreement.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalIndependence.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedInstance.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedNat.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/BundleClose.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/BundleMapClasses.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/BundleTensor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/CanonExistence.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/CanonTransport.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/CanonicalFrame.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ChainAgreement.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ChordCount.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ChordLabels.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ChordParity.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ChordSwapParity.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotate.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotateLeft.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/CloseUnion.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedAgreement.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedCutDispatch.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedIdentify.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ColourEmbedding.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ColourRecursion.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeAssoc.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeNormal.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeRelabel.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/Composition.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/CompositionEquiv.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ConnectionRank.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseAssembly.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseDischarge.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseFamily.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseGram.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseIdentity.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseLift.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ConversePair.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseTrip.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/CrossingDelta.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/CutSubsetSum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/DirMatching.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/DisjSubsetSplit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeColouring.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/Eulerian.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ExactPairingInstance.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/FibreValue.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/FlagGraph.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignForm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/GenBoundaryStates.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/GlueAmbient.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChords.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/GlueComm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCrossDelta.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/GlueFold.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/GlueLedger.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/GluePathMatch.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/GlueRelTransport.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/A.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/C.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSubsetBij.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/GramRank.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/HomCompose.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/HomSpaces.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/HomTensor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceCyclic.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceNondegenerate.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLawRight.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceAlternate.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceContract.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceCut.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceOrderIso.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceShift.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/InvolutionCard.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/LabelChords.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerCast.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerStage.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerValue.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/LoopExample.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/LoopVerify.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/MixedPartition.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalInstance.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalNat.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalStruct.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/Multiplicativity.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/NonSeparatedStep.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/OpenCircuits.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/OrbitParities.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/OrientExistence.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/PairCloseComm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/PairingConnectivity.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSignature.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSwap.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/PairingValue.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/PartialClose.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseCompose.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/PathCanon.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/PathMatch.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/PermCompose.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/PermFragment.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/PropThreeOpen.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/RelTransition.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/RelValue.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelChords.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelInvariance.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/RepairInvariance.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/RigidInstance.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/RigidityClasses.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarClass.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarFunctional.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/SeparatedParity.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/SimpleUnit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCatInstance.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCategory.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdeal.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdealLeft.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinLinear.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/SnakeClasses.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/StarCompClass.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/StarDecomposition.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/StarEnum.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/StarExplode.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/StarPrep.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/StarTrace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/StateFlipSet.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/StatusSet.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/StepFrame.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/StepLedger.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatus.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatusNonsep.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/StrandBundle.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/SumLexOrder.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/SuperGram.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/SuperSpace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/TensorAssoc.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/TensorComm.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/TensorCompClass.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/TensorFragment.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/TensorIdeal.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/TensorUnit.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughEdgeCut.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughIndCFalse.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughValue.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/Trace.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/TraceCyclic.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/TraceNondegenerate.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionMove.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/TransposeLedger.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathNonSep.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathStep.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/VertexOddSign.lean create mode 100644 LeanPool/RegtsSevenster/RS/Novel/Skein/VertexSum.lean create mode 100644 LeanPool/RegtsSevenster/RS/QuantSector.lean create mode 100644 LeanPool/RegtsSevenster/RS/StatementConverse.lean create mode 100644 LeanPool/RegtsSevenster/RS/Summit.lean create mode 100644 LeanPool/RegtsSevenster/RS/TheoremConverse.lean create mode 100644 LeanPool/RegtsSevenster/RS/TheoremDimension.lean create mode 100644 LeanPool/RegtsSevenster/RS/TheoremForward.lean create mode 100644 LeanPool/RegtsSevenster/RS/TheoremPadding.lean create mode 100644 LeanPool/RegtsSevenster/RS/TheoremQuant.lean create mode 100644 LeanPool/RegtsSevenster/RS/TheoremTotal.lean create mode 100644 LeanPool/RegtsSevenster/Solution.lean diff --git a/LeanPool.lean b/LeanPool.lean index 50fa6e5b30..e9e557b52f 100644 --- a/LeanPool.lean +++ b/LeanPool.lean @@ -6221,6 +6221,844 @@ import LeanPool.Redhill.Odd.Pell import LeanPool.Redhill.Odd.Subsum import LeanPool.Redhill.ToMathlib.NatAbs import LeanPool.Redhill.ToMathlib.NatSumProd +import LeanPool.RegtsSevenster +import LeanPool.RegtsSevenster.RS +import LeanPool.RegtsSevenster.RS.Assembly.Blueprint +import LeanPool.RegtsSevenster.RS.Assembly.BlueprintConverse +import LeanPool.RegtsSevenster.RS.Assembly.BlueprintDeligne +import LeanPool.RegtsSevenster.RS.Assembly.BlueprintFactorial +import LeanPool.RegtsSevenster.RS.Assembly.BlueprintSchur +import LeanPool.RegtsSevenster.RS.Assembly.BlueprintStatement +import LeanPool.RegtsSevenster.RS.Classical +import LeanPool.RegtsSevenster.RS.Classical.Algebra.FactorialTrace +import LeanPool.RegtsSevenster.RS.Classical.Algebra.TraceCriterion +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Growth +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Intertwine +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiLinear +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiTrace +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LengthBound +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LinearCategory +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.PartialTrace +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.TensorPow +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Trace +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +import LeanPool.RegtsSevenster.RS.Classical.Deligne +import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPowAct +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeAdjoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeCoherence +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeFree +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeLinear +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeZigzag +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensorUnit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodTransfer +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BlockUnits +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BraidCoherence +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGr +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGraded +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGradedLaws +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBInd +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBNonzero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBofA +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBridge +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainDelta +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.Base +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.FirstSlot +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.SecondSlot +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMul +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulHet +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainNonzero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainShift +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainStage2 +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainUnit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CharSplit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CommonAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoprodPreserve +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescent +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescentClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableNullstellensatz +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoverFactor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CycleSplit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayCalculus +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayType +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DeligneAssembly +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DescentClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DevissageBound +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledAbelian +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledGrowth +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledLine +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledScalar +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSmall +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSplit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DualityMate +import LeanPool.RegtsSevenster.RS.Classical.Deligne.EvenEmbedMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ExactFromShort +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FactorialBeats +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreBridge +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreEps +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreExact +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFaithful +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFunctor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreLinear +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMix +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMu +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMuNat +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverComplex +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverSplitting +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreRestrict +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreStrong +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FiltNil +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FlatLimit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeCollapseAlg +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeMixRetract +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModAdjoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModFunctor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffleCoh +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormalise +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseBase +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseStep +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowDesc +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowInsert +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSlide +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSummand +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeTwistPi +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaComplex +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaCountable +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairAdd +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeFree +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeMix +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetract +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetractRight +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairUnit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaShift +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaTwistLeft +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GeneratorAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GrowthDichotomy +import LeanPool.RegtsSevenster.RS.Classical.Deligne.HomFinite +import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookMult +import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookZero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdemCut +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdempotentLength +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ImageSubalgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndAllColim +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndBigTensorUnit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCoeq +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCompact +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndDayClosure +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndImage +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndKill +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndLocallyMixed +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfLinear +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndPointTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchurKilled +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSimple +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplitSection +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndUnitNonzero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitState +import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KernelPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaData +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KillerNonempty +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KronKill +import LeanPool.RegtsSevenster.RS.Classical.Deligne.LambdaCoend +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixDegenerate +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffleLine +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixSumPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhisker +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhiskerAll +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedConc +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedDiag +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedTransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAbelian +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAssoc +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModContractL +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModCross +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModDual +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModIns +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMulti +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMultiTriple +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowCast +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescent +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescentClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowStage +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchur +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchurSummand +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModZero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MuInterchange +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MulBy +import LeanPool.RegtsSevenster.RS.Classical.Deligne.NatChain +import LeanPool.RegtsSevenster.RS.Classical.Deligne.NewtonConv +import LeanPool.RegtsSevenster.RS.Classical.Deligne.NullPoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLineMap +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddParity +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddPermSign +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquare +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquareIso +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairCarrier +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairMul +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairPerm +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermNat +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermRepChar +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PlainShuffle +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointBaseChange +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointFibre +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Calculus +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Coherence +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Comparison +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Functor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Residue +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowActMul +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowInduct +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowMerge +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairSucc +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairing +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSucc +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSuccMod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowTriangle +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZig +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZigzag +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PresentedQuotient +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21 +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21Core +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21General +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29Close +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Bridge +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Chain +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Close +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Ind +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Reduce +import LeanPool.RegtsSevenster.RS.Classical.Deligne.RegularSum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoTwist +import LeanPool.RegtsSevenster.RS.Classical.Deligne.RowColIdem +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichMerge +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichZig +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarBraiding +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitEquiv +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitInd +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurTransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SeedIns +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeFintype +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SignConj +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleGenerator +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimplePoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleScalars +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleSplit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SmallReduction +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAdjoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAssemble +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitClosure +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitComplement +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitEverything +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExact +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtract +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtractDual +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitMonHom +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitPairDef +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitReduce +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitTransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplittingAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.StateTransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepA +import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepATransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepB +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Letters +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Signs +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Standard +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEvenRing +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGamma +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGammaInst +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModAbelian +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprodMap +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModIso +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShift +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShiftUnit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperPointMod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperRealize +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSeries +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSmall +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperValues +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperVectSchur +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorPowZero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorTransfer +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorZigzag +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TrichotomyClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistCoherence +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistFreeTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistMixLine +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistShuffle +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistState +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistSymPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistUnitor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitBase +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitFreeMod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitMod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitStage +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UniversalAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.WhiskerFaithful +import LeanPool.RegtsSevenster.RS.Classical.Deligne.WordMap +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZagAction +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagNonzero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagSandwich +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransfer +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransferIso +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneBridge +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackageRestrict +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneTheorem +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.FibreTransport +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.KoszulAction +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaPerm +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaTensorPower +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorDischarge +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorIntertwine +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.TotalDimension +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BlockKill +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BranchTrace +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CentralElem +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharClass +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharDecomp +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharEquiv +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourCycleSum +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CommutantBound +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ContentCount +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleFactor +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSum +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSumPrep +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.EndSum +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FibreCard +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FixWeight +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.HVal +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.IdempotentBridge +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTChar +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIntChar +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIrreducible +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTOrtho +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTPad +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTSimple +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.KillSimples +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedCount +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedFixed +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeAction +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.OrbitBridge +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.Package +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairChar +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairInner +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairOrbit +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairStab +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairTuple +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairingPos +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PermModule +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.RegularTrace +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SameCycleQuot +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ScalarTrace +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SchurAction +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SigmaCycleType +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignResolve +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignedTensor +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SimpleEmbed +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowth +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowthSharp +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareStair +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.StabCount +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorNonvanishing +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorTrace +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.WordCommutant +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourAction +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConj +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjStep +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjTop +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourEval +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourExtendSwap +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourFormMatch +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMerge +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMergeOdd +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairing +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairingSymm +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourTotal +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord +import LeanPool.RegtsSevenster.RS.Classical.Super.OrthonormalBasis +import LeanPool.RegtsSevenster.RS.Classical.Super.PowBraid +import LeanPool.RegtsSevenster.RS.Classical.Super.SuperVect +import LeanPool.RegtsSevenster.RS.Classical.Super.SymplecticBasis +import LeanPool.RegtsSevenster.RS.Classical.Super.TotalSpace +import LeanPool.RegtsSevenster.RS.Classical.Super.WordSignPerm +import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantExpand +import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantPieri +import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantStrict +import LeanPool.RegtsSevenster.RS.Classical.SymFun.Bialternant +import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialDet +import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialH +import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffExtract +import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffSplit +import LeanPool.RegtsSevenster.RS.Classical.SymFun.DeltaSeq +import LeanPool.RegtsSevenster.RS.Classical.SymFun.DescVandermonde +import LeanPool.RegtsSevenster.RS.Classical.SymFun.DimFormula +import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHConv +import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHDischarge +import LeanPool.RegtsSevenster.RS.Classical.SymFun.HInsert +import LeanPool.RegtsSevenster.RS.Classical.SymFun.HProdCoeff +import LeanPool.RegtsSevenster.RS.Classical.SymFun.HSubZ +import LeanPool.RegtsSevenster.RS.Classical.SymFun.HookVanishing +import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTDetExpand +import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTGuard +import LeanPool.RegtsSevenster.RS.Classical.SymFun.LGVStrict +import LeanPool.RegtsSevenster.RS.Classical.SymFun.PieriChain +import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowCount +import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums +import LeanPool.RegtsSevenster.RS.Classical.SymFun.RationalityFromRecurrence +import LeanPool.RegtsSevenster.RS.Classical.SymFun.RecurrenceFromVanishing +import LeanPool.RegtsSevenster.RS.Classical.SymFun.SubsetEH +import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums +import LeanPool.RegtsSevenster.RS.Classical.SymFun.TCount +import LeanPool.RegtsSevenster.RS.Classical.SymFun.TIdentity +import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaExp +import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaRational +import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaSeries +import LeanPool.RegtsSevenster.RS.Common +import LeanPool.RegtsSevenster.RS.Common.DiagramChain +import LeanPool.RegtsSevenster.RS.Common.ExponentialGrowth +import LeanPool.RegtsSevenster.RS.Common.FactorialBound +import LeanPool.RegtsSevenster.RS.Common.FinSlots +import LeanPool.RegtsSevenster.RS.Common.ListAttach +import LeanPool.RegtsSevenster.RS.Common.ListPairs +import LeanPool.RegtsSevenster.RS.Common.ListSign +import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +import LeanPool.RegtsSevenster.RS.Common.NilpotentMap +import LeanPool.RegtsSevenster.RS.Common.NilpotentPowerTrace +import LeanPool.RegtsSevenster.RS.Common.PairDisjoint +import LeanPool.RegtsSevenster.RS.Common.PermCongr +import LeanPool.RegtsSevenster.RS.Common.PermTopSplit +import LeanPool.RegtsSevenster.RS.Common.ProdSum +import LeanPool.RegtsSevenster.RS.Common.RowLenChain +import LeanPool.RegtsSevenster.RS.Common.RowSpanRank +import LeanPool.RegtsSevenster.RS.Common.TraceSeparation +import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams +import LeanPool.RegtsSevenster.RS.Definitions +import LeanPool.RegtsSevenster.RS.DimensionDefinitions +import LeanPool.RegtsSevenster.RS.Glossary +import LeanPool.RegtsSevenster.RS.Novel +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjSwapBmc +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjacentWord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisCoord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisSplit +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaData +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiag +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiagForm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaFlip +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockCanon +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockOddList +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockParity +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockRestrict +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSigma +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSort +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BraidWord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonColour +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapClosed +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapExpansion +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapFun +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapMatch +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeel +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeelSplit +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapSplit +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapVal +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ChainLists +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleModel +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleScalar +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircuitCount +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ClosedTransition +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ConcatSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordInterface +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordOf +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoreParity +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EdgeSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvForm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvFormOdd +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvLeaf +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FibreParam +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FlagEnum +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.GlobalSlotList +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.HRS +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ListSignPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MasterSum +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelCoord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelStarVec +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MultiStar +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFDef +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFValue +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddFlip +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddListMultiset +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddPair +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddSignProd +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaCotensor +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTensor +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTransport +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OneBasis +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OrbitCard +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OutSignEdges +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairEnum +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairList +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ParameterModel +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PatternInv +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RegroupSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.Reindex +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexHeart +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexVanish +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RiffleSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SignPair +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SkeinPowBraid +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SlotPairing +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortFactor +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarClassFactor +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPeel +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarRepeat +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarSymm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarTensorClass +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StdTransport +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StrandTransport +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauCount +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TopBraidMerge +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TwoBasis +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue +import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomDichotomy +import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomicIdempotents +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockAssembly +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockBounds +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockCycle +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactor +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactorialTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockSplice +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockTower +import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleNormal +import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvAbelian +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDeligne +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDelignePackage +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGenerator +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGrowth +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvSemisimple +import LeanPool.RegtsSevenster.RS.Novel.Envelope.FactorialTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.Frobenius +import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement +import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinementSharp +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiEmbBraided +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiMonoidal +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiRigid +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiSemisimple +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatBraided +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatEmbMonoidal +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatMonoidal +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatRigid +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatSemisimple +import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentMatTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.ObjectTower +import LeanPool.RegtsSevenster.RS.Novel.Envelope.PermTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.RankDimension +import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarPermTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleAll +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleEnd +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinDimBound +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SuperKill +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast +import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowHom +import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowSplit +import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZeta +import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZetaSharp +import LeanPool.RegtsSevenster.RS.Novel.Extraction.CircleValue +import LeanPool.RegtsSevenster.RS.Novel.Extraction.CoordIso +import LeanPool.RegtsSevenster.RS.Novel.Extraction.Coordinates +import LeanPool.RegtsSevenster.RS.Novel.Extraction.CopairUnique +import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate +import LeanPool.RegtsSevenster.RS.Novel.Extraction.SnakeTransport +import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdDuality +import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid +import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper +import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalAgreement +import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalIndependence +import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedNat +import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleClose +import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleMapClasses +import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleTensor +import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence +import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonTransport +import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonicalFrame +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChainAgreement +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordCount +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordParity +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordSwapParity +import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate +import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotateLeft +import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseUnion +import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedAgreement +import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedCutDispatch +import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedIdentify +import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedTopSum +import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourEmbedding +import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourGlue +import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourPadding +import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourRecursion +import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc +import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeNormal +import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeRelabel +import LeanPool.RegtsSevenster.RS.Novel.Skein.Composition +import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseAssembly +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseFamily +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseGram +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseIdentity +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseLift +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConversePair +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseTrip +import LeanPool.RegtsSevenster.RS.Novel.Skein.CrossingDelta +import LeanPool.RegtsSevenster.RS.Novel.Skein.CutMatching +import LeanPool.RegtsSevenster.RS.Novel.Skein.CutSubsetSum +import LeanPool.RegtsSevenster.RS.Novel.Skein.DirMatching +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjSubsetSplit +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.A +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.B +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.C +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionProduct +import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeColouring +import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeSum +import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeTerm +import LeanPool.RegtsSevenster.RS.Novel.Skein.Eulerian +import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.FibreValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.FlagGraph +import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignForm +import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignProduct +import LeanPool.RegtsSevenster.RS.Novel.Skein.FourLabelParity +import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv +import LeanPool.RegtsSevenster.RS.Novel.Skein.GenBoundaryStates +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueAmbient +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChord +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChords +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCircuitDelta +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueComm +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueLedger +import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueRelTransport +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplit +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.A +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.C +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSubsetBij +import LeanPool.RegtsSevenster.RS.Novel.Skein.GramRank +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomCompose +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomSpaces +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceCyclic +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate +import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw +import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceAlternate +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceContract +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceCut +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceOrderIso +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceShift +import LeanPool.RegtsSevenster.RS.Novel.Skein.InvolutionCard +import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerCast +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerRecursion +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerSets +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerStage +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopExample +import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopVerify +import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition +import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalNat +import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalStruct +import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity +import LeanPool.RegtsSevenster.RS.Novel.Skein.NonSeparatedStep +import LeanPool.RegtsSevenster.RS.Novel.Skein.OpenCircuits +import LeanPool.RegtsSevenster.RS.Novel.Skein.OrbitParities +import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientExistence +import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientationFlip +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairCloseComm +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairedAssembly +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSwap +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialClose +import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseCompose +import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseTensor +import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon +import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger +import LeanPool.RegtsSevenster.RS.Novel.Skein.PathMatch +import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose +import LeanPool.RegtsSevenster.RS.Novel.Skein.PermFragment +import LeanPool.RegtsSevenster.RS.Novel.Skein.PropThreeOpen +import LeanPool.RegtsSevenster.RS.Novel.Skein.RSTensor +import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition +import LeanPool.RegtsSevenster.RS.Novel.Skein.RelValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelChords +import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelInvariance +import LeanPool.RegtsSevenster.RS.Novel.Skein.RepairInvariance +import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidityClasses +import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarClass +import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarFunctional +import LeanPool.RegtsSevenster.RS.Novel.Skein.SeparatedParity +import LeanPool.RegtsSevenster.RS.Novel.Skein.SimpleUnit +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCategory +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdealLeft +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinLinear +import LeanPool.RegtsSevenster.RS.Novel.Skein.SnakeClasses +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarCompClass +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarDecomposition +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarEnum +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarExplode +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarPrep +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarTrace +import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet +import LeanPool.RegtsSevenster.RS.Novel.Skein.StatusSet +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepFrame +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatus +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatusNonsep +import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle +import LeanPool.RegtsSevenster.RS.Novel.Skein.SumLexOrder +import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperGram +import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperSpace +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorAssoc +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorComm +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorCompClass +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorInterchange +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorUnit +import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut +import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughIndCFalse +import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.Trace +import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic +import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceNondegenerate +import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists +import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionMove +import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger +import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathNonSep +import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathStep +import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexOddSign +import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexSum +import LeanPool.RegtsSevenster.RS.QuantSector +import LeanPool.RegtsSevenster.RS.StatementConverse +import LeanPool.RegtsSevenster.RS.Summit +import LeanPool.RegtsSevenster.RS.TheoremConverse +import LeanPool.RegtsSevenster.RS.TheoremDimension +import LeanPool.RegtsSevenster.RS.TheoremForward +import LeanPool.RegtsSevenster.RS.TheoremPadding +import LeanPool.RegtsSevenster.RS.TheoremQuant +import LeanPool.RegtsSevenster.RS.TheoremTotal +import LeanPool.RegtsSevenster.Solution import LeanPool.RellichKondrachov import LeanPool.RellichKondrachov.Analysis.Calculus.ContDiff.Support import LeanPool.RellichKondrachov.Analysis.FunctionalSpaces.Sobolev.Euclidean.H1 diff --git a/LeanPool/RegtsSevenster.lean b/LeanPool/RegtsSevenster.lean new file mode 100644 index 0000000000..77612bf50f --- /dev/null +++ b/LeanPool/RegtsSevenster.lean @@ -0,0 +1,854 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS +import LeanPool.RegtsSevenster.RS.Assembly.Blueprint +import LeanPool.RegtsSevenster.RS.Assembly.BlueprintConverse +import LeanPool.RegtsSevenster.RS.Assembly.BlueprintDeligne +import LeanPool.RegtsSevenster.RS.Assembly.BlueprintFactorial +import LeanPool.RegtsSevenster.RS.Assembly.BlueprintSchur +import LeanPool.RegtsSevenster.RS.Assembly.BlueprintStatement +import LeanPool.RegtsSevenster.RS.Classical +import LeanPool.RegtsSevenster.RS.Classical.Algebra.FactorialTrace +import LeanPool.RegtsSevenster.RS.Classical.Algebra.TraceCriterion +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Growth +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Intertwine +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiLinear +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiTrace +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LengthBound +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LinearCategory +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.PartialTrace +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.TensorPow +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Trace +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +import LeanPool.RegtsSevenster.RS.Classical.Deligne +import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPowAct +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeAdjoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeCoherence +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeFree +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeLinear +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeZigzag +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensorUnit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodTransfer +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BlockUnits +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BraidCoherence +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGr +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGraded +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGradedLaws +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBInd +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBNonzero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBofA +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBridge +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainDelta +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.Base +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.FirstSlot +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.SecondSlot +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMul +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulHet +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainNonzero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainShift +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainStage2 +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainUnit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CharSplit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CommonAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoprodPreserve +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescent +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescentClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableNullstellensatz +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoverFactor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CycleSplit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayCalculus +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayType +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DeligneAssembly +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DescentClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DevissageBound +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledAbelian +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledGrowth +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledLine +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledScalar +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSmall +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSplit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DualityMate +import LeanPool.RegtsSevenster.RS.Classical.Deligne.EvenEmbedMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ExactFromShort +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FactorialBeats +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreBridge +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreEps +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreExact +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFaithful +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFunctor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreLinear +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMix +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMu +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMuNat +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverComplex +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverSplitting +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreRestrict +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreStrong +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FiltNil +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FlatLimit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeCollapseAlg +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeMixRetract +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModAdjoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModFunctor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffleCoh +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormalise +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseBase +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseStep +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowDesc +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowInsert +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSlide +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSummand +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeTwistPi +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaComplex +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaCountable +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairAdd +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeFree +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeMix +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetract +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetractRight +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairUnit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaShift +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaTwistLeft +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GeneratorAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GrowthDichotomy +import LeanPool.RegtsSevenster.RS.Classical.Deligne.HomFinite +import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookMult +import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookZero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdemCut +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdempotentLength +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ImageSubalgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndAllColim +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndBigTensorUnit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCoeq +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCompact +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndDayClosure +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndImage +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndKill +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndLocallyMixed +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfLinear +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndPointTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchurKilled +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSimple +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplitSection +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndUnitNonzero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitState +import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KernelPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaData +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KillerNonempty +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KronKill +import LeanPool.RegtsSevenster.RS.Classical.Deligne.LambdaCoend +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixDegenerate +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffleLine +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixSumPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhisker +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhiskerAll +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedConc +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedDiag +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedTransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAbelian +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAssoc +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModContractL +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModCross +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModDual +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModIns +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMulti +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMultiTriple +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowCast +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescent +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescentClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowStage +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchur +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchurSummand +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModZero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MuInterchange +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MulBy +import LeanPool.RegtsSevenster.RS.Classical.Deligne.NatChain +import LeanPool.RegtsSevenster.RS.Classical.Deligne.NewtonConv +import LeanPool.RegtsSevenster.RS.Classical.Deligne.NullPoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLineMap +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddParity +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddPermSign +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquare +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquareIso +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairCarrier +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairMul +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairPerm +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermNat +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermRepChar +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PlainShuffle +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointBaseChange +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointFibre +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Calculus +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Coherence +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Comparison +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Functor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Residue +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowActMul +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowInduct +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowMerge +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairSucc +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairing +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSucc +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSuccMod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowTriangle +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZig +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZigzag +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PresentedQuotient +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21 +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21Core +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21General +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29Close +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Bridge +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Chain +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Close +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Ind +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Reduce +import LeanPool.RegtsSevenster.RS.Classical.Deligne.RegularSum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoTwist +import LeanPool.RegtsSevenster.RS.Classical.Deligne.RowColIdem +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichMerge +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichZig +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarBraiding +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitEquiv +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitInd +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurTransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SeedIns +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeFintype +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SignConj +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleGenerator +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimplePoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleScalars +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleSplit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SmallReduction +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAdjoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAssemble +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitClosure +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitComplement +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitEverything +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExact +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtract +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtractDual +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitMonHom +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitPairDef +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitReduce +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitTransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplittingAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.StateTransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepA +import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepATransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepB +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Letters +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Signs +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Standard +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEvenRing +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGamma +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGammaInst +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModAbelian +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprodMap +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModIso +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShift +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShiftUnit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperPointMod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperRealize +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSeries +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSmall +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperValues +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperVectSchur +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorPowZero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorTransfer +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorZigzag +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TrichotomyClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistCoherence +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistFreeTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistMixLine +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistShuffle +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistState +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistSymPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistUnitor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitBase +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitFreeMod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitMod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitStage +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UniversalAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.WhiskerFaithful +import LeanPool.RegtsSevenster.RS.Classical.Deligne.WordMap +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZagAction +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagNonzero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagSandwich +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransfer +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransferIso +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneBridge +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackageRestrict +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneTheorem +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.FibreTransport +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.KoszulAction +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaPerm +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaTensorPower +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorDischarge +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorIntertwine +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.TotalDimension +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BlockKill +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BranchTrace +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CentralElem +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharClass +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharDecomp +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharEquiv +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourCycleSum +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CommutantBound +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ContentCount +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleFactor +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSum +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSumPrep +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.EndSum +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FibreCard +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FixWeight +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.HVal +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.IdempotentBridge +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTChar +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIntChar +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIrreducible +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTOrtho +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTPad +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTSimple +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.KillSimples +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedCount +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedFixed +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeAction +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.OrbitBridge +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.Package +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairChar +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairInner +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairOrbit +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairStab +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairTuple +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairingPos +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PermModule +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.RegularTrace +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SameCycleQuot +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ScalarTrace +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SchurAction +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SigmaCycleType +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignResolve +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignedTensor +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SimpleEmbed +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowth +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowthSharp +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareStair +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.StabCount +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorNonvanishing +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorTrace +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.WordCommutant +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourAction +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConj +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjStep +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjTop +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourEval +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourExtendSwap +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourFormMatch +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMerge +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMergeOdd +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairing +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairingSymm +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourTotal +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord +import LeanPool.RegtsSevenster.RS.Classical.Super.OrthonormalBasis +import LeanPool.RegtsSevenster.RS.Classical.Super.PowBraid +import LeanPool.RegtsSevenster.RS.Classical.Super.SuperVect +import LeanPool.RegtsSevenster.RS.Classical.Super.SymplecticBasis +import LeanPool.RegtsSevenster.RS.Classical.Super.TotalSpace +import LeanPool.RegtsSevenster.RS.Classical.Super.WordSignPerm +import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantExpand +import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantPieri +import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantStrict +import LeanPool.RegtsSevenster.RS.Classical.SymFun.Bialternant +import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialDet +import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialH +import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffExtract +import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffSplit +import LeanPool.RegtsSevenster.RS.Classical.SymFun.DeltaSeq +import LeanPool.RegtsSevenster.RS.Classical.SymFun.DescVandermonde +import LeanPool.RegtsSevenster.RS.Classical.SymFun.DimFormula +import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHConv +import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHDischarge +import LeanPool.RegtsSevenster.RS.Classical.SymFun.HInsert +import LeanPool.RegtsSevenster.RS.Classical.SymFun.HProdCoeff +import LeanPool.RegtsSevenster.RS.Classical.SymFun.HSubZ +import LeanPool.RegtsSevenster.RS.Classical.SymFun.HookVanishing +import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTDetExpand +import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTGuard +import LeanPool.RegtsSevenster.RS.Classical.SymFun.LGVStrict +import LeanPool.RegtsSevenster.RS.Classical.SymFun.PieriChain +import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowCount +import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums +import LeanPool.RegtsSevenster.RS.Classical.SymFun.RationalityFromRecurrence +import LeanPool.RegtsSevenster.RS.Classical.SymFun.RecurrenceFromVanishing +import LeanPool.RegtsSevenster.RS.Classical.SymFun.SubsetEH +import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums +import LeanPool.RegtsSevenster.RS.Classical.SymFun.TCount +import LeanPool.RegtsSevenster.RS.Classical.SymFun.TIdentity +import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaExp +import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaRational +import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaSeries +import LeanPool.RegtsSevenster.RS.Common +import LeanPool.RegtsSevenster.RS.Common.DiagramChain +import LeanPool.RegtsSevenster.RS.Common.ExponentialGrowth +import LeanPool.RegtsSevenster.RS.Common.FactorialBound +import LeanPool.RegtsSevenster.RS.Common.FinSlots +import LeanPool.RegtsSevenster.RS.Common.ListAttach +import LeanPool.RegtsSevenster.RS.Common.ListPairs +import LeanPool.RegtsSevenster.RS.Common.ListSign +import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +import LeanPool.RegtsSevenster.RS.Common.NilpotentMap +import LeanPool.RegtsSevenster.RS.Common.NilpotentPowerTrace +import LeanPool.RegtsSevenster.RS.Common.PairDisjoint +import LeanPool.RegtsSevenster.RS.Common.PermCongr +import LeanPool.RegtsSevenster.RS.Common.PermTopSplit +import LeanPool.RegtsSevenster.RS.Common.ProdSum +import LeanPool.RegtsSevenster.RS.Common.RowLenChain +import LeanPool.RegtsSevenster.RS.Common.RowSpanRank +import LeanPool.RegtsSevenster.RS.Common.TraceSeparation +import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams +import LeanPool.RegtsSevenster.RS.Definitions +import LeanPool.RegtsSevenster.RS.DimensionDefinitions +import LeanPool.RegtsSevenster.RS.Glossary +import LeanPool.RegtsSevenster.RS.Novel +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjSwapBmc +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjacentWord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisCoord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisSplit +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaData +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiag +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiagForm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaFlip +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockCanon +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockOddList +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockParity +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockRestrict +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSigma +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSort +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BraidWord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonColour +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapClosed +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapExpansion +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapFun +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapMatch +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeel +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeelSplit +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapSplit +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapVal +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ChainLists +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleModel +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleScalar +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircuitCount +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ClosedTransition +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ConcatSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordInterface +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordOf +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoreParity +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EdgeSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvForm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvFormOdd +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvLeaf +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FibreParam +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FlagEnum +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.GlobalSlotList +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.HRS +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ListSignPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MasterSum +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelCoord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelStarVec +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MultiStar +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFDef +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFValue +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddFlip +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddListMultiset +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddPair +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddSignProd +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaCotensor +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTensor +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTransport +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OneBasis +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OrbitCard +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OutSignEdges +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairEnum +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairList +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ParameterModel +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PatternInv +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RegroupSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.Reindex +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexHeart +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexVanish +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RiffleSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SignPair +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SkeinPowBraid +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SlotPairing +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortFactor +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarClassFactor +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPeel +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarRepeat +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarSymm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarTensorClass +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StdTransport +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StrandTransport +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauCount +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TopBraidMerge +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TwoBasis +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue +import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomDichotomy +import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomicIdempotents +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockAssembly +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockBounds +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockCycle +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactor +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactorialTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockSplice +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockTower +import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleNormal +import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvAbelian +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDeligne +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDelignePackage +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGenerator +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGrowth +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvSemisimple +import LeanPool.RegtsSevenster.RS.Novel.Envelope.FactorialTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.Frobenius +import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement +import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinementSharp +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiEmbBraided +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiMonoidal +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiRigid +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiSemisimple +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatBraided +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatEmbMonoidal +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatMonoidal +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatRigid +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatSemisimple +import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentMatTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.ObjectTower +import LeanPool.RegtsSevenster.RS.Novel.Envelope.PermTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.RankDimension +import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarPermTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleAll +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleEnd +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinDimBound +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SuperKill +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast +import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowHom +import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowSplit +import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZeta +import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZetaSharp +import LeanPool.RegtsSevenster.RS.Novel.Extraction.CircleValue +import LeanPool.RegtsSevenster.RS.Novel.Extraction.CoordIso +import LeanPool.RegtsSevenster.RS.Novel.Extraction.Coordinates +import LeanPool.RegtsSevenster.RS.Novel.Extraction.CopairUnique +import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate +import LeanPool.RegtsSevenster.RS.Novel.Extraction.SnakeTransport +import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdDuality +import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid +import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper +import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalAgreement +import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalIndependence +import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedNat +import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleClose +import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleMapClasses +import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleTensor +import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence +import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonTransport +import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonicalFrame +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChainAgreement +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordCount +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordParity +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordSwapParity +import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate +import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotateLeft +import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseUnion +import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedAgreement +import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedCutDispatch +import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedIdentify +import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedTopSum +import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourEmbedding +import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourGlue +import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourPadding +import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourRecursion +import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc +import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeNormal +import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeRelabel +import LeanPool.RegtsSevenster.RS.Novel.Skein.Composition +import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseAssembly +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseFamily +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseGram +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseIdentity +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseLift +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConversePair +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseTrip +import LeanPool.RegtsSevenster.RS.Novel.Skein.CrossingDelta +import LeanPool.RegtsSevenster.RS.Novel.Skein.CutMatching +import LeanPool.RegtsSevenster.RS.Novel.Skein.CutSubsetSum +import LeanPool.RegtsSevenster.RS.Novel.Skein.DirMatching +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjSubsetSplit +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.A +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.B +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.C +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionProduct +import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeColouring +import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeSum +import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeTerm +import LeanPool.RegtsSevenster.RS.Novel.Skein.Eulerian +import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.FibreValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.FlagGraph +import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignForm +import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignProduct +import LeanPool.RegtsSevenster.RS.Novel.Skein.FourLabelParity +import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv +import LeanPool.RegtsSevenster.RS.Novel.Skein.GenBoundaryStates +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueAmbient +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChord +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChords +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCircuitDelta +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueComm +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueLedger +import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueRelTransport +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplit +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.A +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.C +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSubsetBij +import LeanPool.RegtsSevenster.RS.Novel.Skein.GramRank +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomCompose +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomSpaces +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceCyclic +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate +import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw +import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceAlternate +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceContract +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceCut +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceOrderIso +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceShift +import LeanPool.RegtsSevenster.RS.Novel.Skein.InvolutionCard +import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerCast +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerRecursion +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerSets +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerStage +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopExample +import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopVerify +import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition +import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalNat +import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalStruct +import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity +import LeanPool.RegtsSevenster.RS.Novel.Skein.NonSeparatedStep +import LeanPool.RegtsSevenster.RS.Novel.Skein.OpenCircuits +import LeanPool.RegtsSevenster.RS.Novel.Skein.OrbitParities +import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientExistence +import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientationFlip +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairCloseComm +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairedAssembly +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSwap +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialClose +import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseCompose +import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseTensor +import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon +import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger +import LeanPool.RegtsSevenster.RS.Novel.Skein.PathMatch +import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose +import LeanPool.RegtsSevenster.RS.Novel.Skein.PermFragment +import LeanPool.RegtsSevenster.RS.Novel.Skein.PropThreeOpen +import LeanPool.RegtsSevenster.RS.Novel.Skein.RSTensor +import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition +import LeanPool.RegtsSevenster.RS.Novel.Skein.RelValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelChords +import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelInvariance +import LeanPool.RegtsSevenster.RS.Novel.Skein.RepairInvariance +import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidityClasses +import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarClass +import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarFunctional +import LeanPool.RegtsSevenster.RS.Novel.Skein.SeparatedParity +import LeanPool.RegtsSevenster.RS.Novel.Skein.SimpleUnit +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCategory +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdealLeft +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinLinear +import LeanPool.RegtsSevenster.RS.Novel.Skein.SnakeClasses +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarCompClass +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarDecomposition +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarEnum +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarExplode +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarPrep +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarTrace +import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet +import LeanPool.RegtsSevenster.RS.Novel.Skein.StatusSet +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepFrame +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatus +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatusNonsep +import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle +import LeanPool.RegtsSevenster.RS.Novel.Skein.SumLexOrder +import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperGram +import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperSpace +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorAssoc +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorComm +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorCompClass +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorInterchange +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorUnit +import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut +import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughIndCFalse +import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.Trace +import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic +import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceNondegenerate +import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists +import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionMove +import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger +import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathNonSep +import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathStep +import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexOddSign +import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexSum +import LeanPool.RegtsSevenster.RS.QuantSector +import LeanPool.RegtsSevenster.RS.StatementConverse +import LeanPool.RegtsSevenster.RS.Summit +import LeanPool.RegtsSevenster.RS.TheoremConverse +import LeanPool.RegtsSevenster.RS.TheoremDimension +import LeanPool.RegtsSevenster.RS.TheoremForward +import LeanPool.RegtsSevenster.RS.TheoremPadding +import LeanPool.RegtsSevenster.RS.TheoremQuant +import LeanPool.RegtsSevenster.RS.TheoremTotal +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`, `RS.regts_sevenster_total`, `RS.deligne_theorem` +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..00f2b0e6d9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS.lean @@ -0,0 +1,28 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Common +import LeanPool.RegtsSevenster.RS.Classical +import LeanPool.RegtsSevenster.RS.Novel +import LeanPool.RegtsSevenster.RS.Definitions +import LeanPool.RegtsSevenster.RS.StatementConverse +import LeanPool.RegtsSevenster.RS.TheoremForward +import LeanPool.RegtsSevenster.RS.TheoremQuant +import LeanPool.RegtsSevenster.RS.TheoremTotal +import LeanPool.RegtsSevenster.RS.TheoremConverse +import LeanPool.RegtsSevenster.RS.QuantSector +import LeanPool.RegtsSevenster.RS.Glossary +import LeanPool.RegtsSevenster.RS.Assembly.BlueprintStatement +import LeanPool.RegtsSevenster.RS.Assembly.Blueprint +import LeanPool.RegtsSevenster.RS.Assembly.BlueprintConverse +import LeanPool.RegtsSevenster.RS.Assembly.BlueprintSchur +import LeanPool.RegtsSevenster.RS.Classical.Deligne +import LeanPool.RegtsSevenster.RS.Summit +import LeanPool.RegtsSevenster.RS.Assembly.BlueprintDeligne +import LeanPool.RegtsSevenster.RS.Assembly.BlueprintFactorial +import LeanPool.RegtsSevenster.RS.DimensionDefinitions +import LeanPool.RegtsSevenster.RS.TheoremDimension +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..d1024ae140 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean @@ -0,0 +1,1048 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams +import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourCycleSum +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTOrtho +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignResolve +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowth +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BranchTrace +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTPad +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.Package +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairingPos +import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZeta +import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaExp +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowthSharp +import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinementSharp +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinDimBound +import LeanPool.RegtsSevenster.RS.Novel.Skein.PathMatch +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SuperKill +import LeanPool.RegtsSevenster.RS.StatementConverse +import LeanPool.RegtsSevenster.RS.TheoremQuant +import LeanPool.RegtsSevenster.RS.Classical.SymFun.LGVStrict +import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedAgreement +import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionMove +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueRelTransport +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjSubsetSplit +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceOrderIso +import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelInvariance +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCircuitDelta +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChainAgreement +import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence +import LeanPool.RegtsSevenster.RS.Novel.Skein.RepairInvariance +import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordParity +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger +import LeanPool.RegtsSevenster.RS.Novel.Skein.InvolutionCard +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordCount +import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalIndependence +import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalAgreement +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseAssembly +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceAlternate +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseGram +import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger +import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathNonSep +import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonicalFrame +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepFrame +import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet +import LeanPool.RegtsSevenster.RS.Novel.Skein.StatusSet +import LeanPool.RegtsSevenster.RS.Novel.Skein.CrossingDelta +import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignProduct +import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignForm +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerSets +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatus +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatusNonsep +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairedAssembly +import LeanPool.RegtsSevenster.RS.Novel.Skein.PropThreeOpen +import LeanPool.RegtsSevenster.RS.Novel.Skein.FourLabelParity +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSwap +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopVerify +import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughIndCFalse +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels +import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords +import LeanPool.RegtsSevenster.RS.Novel.Skein.FibreValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChords +import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta +import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedCutDispatch +import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut +import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelChords +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordSwapParity +import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums +import LeanPool.RegtsSevenster.RS.Classical.SymFun.RecurrenceFromVanishing +import LeanPool.RegtsSevenster.RS.Classical.SymFun.RationalityFromRecurrence +import LeanPool.RegtsSevenster.RS.Classical.SymFun.HookVanishing +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockBounds +import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiMonoidal +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatMonoidal +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatBraided +import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleEnd +import LeanPool.RegtsSevenster.RS.Classical.Super.OrthonormalBasis +import LeanPool.RegtsSevenster.RS.Classical.Super.SuperVect +import LeanPool.RegtsSevenster.RS.Classical.Super.SymplecticBasis +import LeanPool.RegtsSevenster.RS.Novel.Skein.FlagGraph +import LeanPool.RegtsSevenster.RS.Novel.Skein.Composition +import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv +import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv +import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle +import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw +import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomSpaces +import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity +import LeanPool.RegtsSevenster.RS.Novel.Skein.Eulerian +import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueAmbient +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueComm +import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate +import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotateLeft +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceShift +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairCloseComm +import LeanPool.RegtsSevenster.RS.Novel.Skein.SimpleUnit +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdealLeft +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomCompose +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCategory +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinLinear +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceCyclic +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarDecomposition +import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc +import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeNormal +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold +import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition +import LeanPool.RegtsSevenster.RS.Novel.Skein.PermFragment +import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose +import LeanPool.RegtsSevenster.RS.Novel.Skein.Trace +import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic +import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceNondegenerate +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorComm +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorAssoc +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorUnit +import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseTensor +import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseUnion +import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeRelabel +import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseCompose +import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarClass +import LeanPool.RegtsSevenster.RS.Definitions +import LeanPool.RegtsSevenster.RS.Novel.Extraction.CircleValue +import LeanPool.RegtsSevenster.RS.Novel.Extraction.CoordIso +import LeanPool.RegtsSevenster.RS.Novel.Extraction.Coordinates +import LeanPool.RegtsSevenster.RS.Novel.Extraction.CopairUnique +import LeanPool.RegtsSevenster.RS.Novel.Extraction.SnakeTransport +import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate +import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdDuality +import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid +import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneBridge +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneTheorem +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.FibreTransport +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarTrace +import LeanPool.RegtsSevenster.RS.Novel.Skein.SnakeClasses +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourFormMatch +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairing +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairingSymm +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorInterchange +import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarCompClass +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTransport +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortFactor +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarClassFactor +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTensor +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleModel +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BraidWord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarSymm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelStarVec +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ParameterModel +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjStep +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord +import LeanPool.RegtsSevenster.RS.Classical.Super.WordSignPerm +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjTop +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourAction +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapClosed +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MasterSum +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarRepeat +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.Reindex +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FibreParam +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockParity +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexVanish +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiagForm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaData +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddFlip +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PatternInv +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ListSignPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OutSignEdges +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EdgeSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddListMultiset +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddSignProd +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaFlip +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircuitCount +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairEnum +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FlagEnum +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockCanon +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockOddList +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauCount +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.GlobalSlotList +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ChainLists +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ConcatSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SignPair +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RiffleSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFDef +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RegroupSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoreParity +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFValue +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexHeart +import LeanPool.RegtsSevenster.RS.TheoremForward +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapVal +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapSplit +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ClosedTransition +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelCoord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OneBasis +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvLeaf +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapExpansion +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeelSplit +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisCoord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiag +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SlotPairing +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TopBraidMerge +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TwoBasis +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. +-/ + +/-- info: 'RS.superPowerSums_of_hook_vanishing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.powerSums_zero_of_eventually_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### 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. +-/ + +/-- info: 'RS.PermTower.hook_confinement' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.FrobeniusTower.traceA_eq_zero_of_isNilpotent' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.isSemisimpleRing_of_trace' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### The classical bases + +The symplectic and orthonormal standard bases the super model is +written in. +-/ + +/-- info: 'RS.exists_symplectic_basis' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.exists_orthonormal_basis' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### Definition 5 and its transport + +The mixed partition value of an edge subset, and its invariance +under a fragment equivalence. +-/ + +/-- info: 'RS.EdgeSubset.mixedSummand_transport' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.mixedPartition_transport' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### 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. +-/ + +/-- info: 'RS.edgeRankBounded_iff_submatrixRank' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### The gluing calculus + +Gluing a list of label pairs: permuting the list, appending, +normalising an interface, and the existence of transition data. +-/ + +/-- info: 'RS.Fragment.glueListPerm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.glueInterfaceNormal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.Fragment.glueListAppend' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeRankParameter.val_union' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.exists_transition_orientation' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.RegtsSevensterStatement' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.composeStrandBundleLeft' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.Fragment.gluePairComm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.composeStrandBundleRight' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### Coordinates and the standard model + +Contraction families, the standard form and copairing, and the +coordinates a nondegenerate pairing gives. +-/ + +/-- info: 'RS.exists_coordinates' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.exists_contraction_families' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.exists_coordinates_of_snake' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.exists_std_iso' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.stdCopair_unique' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.exists_std_model' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.stdForm_comp_stdCopair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### 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. +-/ + +/-- info: 'RS.Fragment.glueListDisjUnionLeft' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.Fragment.glueListDisjUnionRight' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.Fragment.glueListSwap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.composeAssoc' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.pairCloseComposeRotate' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.pairCloseComposeRotateLeft' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.composeFinsupp_ker_left' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.composeFinsupp_ker_right' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.HomSpace.comp_ofFragment' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.HomSpace.comp_assoc' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.HomSpace.comp_id_left' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.HomSpace.comp_id_right' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.HomSpace.eq_zero_of_traces_vanish' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.skeinCategory' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.starDecomposition' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.homSpace_zero_spanned' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.interfaceShift' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.Fragment.pairCloseComm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### The exact pairing + +The self-duality of the standard model, and that it is braided. +-/ + +/-- info: 'RS.ExactPairing.map' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.braided_std_model' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### The trace calculus + +Closing a fragment against the strand bundle: relabels cross it, +tensors absorb, and permutation fragments compose. +-/ + +/-- info: 'RS.pairCloseRelabel' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.fragTrace_comm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.permFragmentCompose' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.mem_ker_of_traces_vanish' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.pairCloseTensorAbsorb' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.tensorFinsupp_ker_left' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.tensorFinsupp_ker_right' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.HomSpace.tensor_ofFragment' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.tensorFragmentAssoc' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.tensorFragmentUnitLeft' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.tensorFragmentUnitRight' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### The braided envelope + +The Karoubi and matrix envelopes inherit the braiding and its +symmetry. +-/ + +/-- info: 'RS.karoubiBraided' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.karoubiSymmetric' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.matBraided' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.matSymmetric' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### The skein category + +Linear, monoidal and rigid structure on the skein category, and +the trace map it carries. +-/ + +/-- info: 'RS.skeinPreadditive' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.skeinLinear' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.HomSpace.traceMap_comp_comm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.partialCloseTensor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.pairCloseUnionRight' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.fragTrace_tensor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.composeRelabelOut' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.composePermFragment' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.partialCloseEqCompose' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.ofFragment_eq_smul_empty' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.pairCloseStrandBundle' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.starDecomposition' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.snake_left' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.snake_right' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.braid_comp_evClass' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.Fragment.tensorComposeInterchange' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.skeinMonoidal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.skeinBraided' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.skeinSymmetric' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.strandExactPairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.strand_ev_symmetry' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.star_comp_class' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### The coordinate model + +The fibre functor's image of a star, the standard model it is +identified with, and the transport between them. +-/ + +/-- info: 'RS.omega_star_scalar' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.skein_std_model' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.starUnionFactor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.starClass_factor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.omegaVec_tensor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.parameter_star_factor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.circleVal_model' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.stdFromOmega_stdToOmega' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.adjWord_spec' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.stdToOmega_powBraid' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.stdToOmega_bmc_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.bundleCapClass_peel' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.point_cotensor' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.omegaFun_tensor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.evForm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.vertexStarClass_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.stdToOmega_merge' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.stdToOmega_modelStarVec' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.toColour_whisker' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.parameter_model' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.colourExtend_colourSwap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.colourSwapWord_evenMap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.parameter_capVal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.ClosedFragment.eulerian_transition_nonempty' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.omegaFun_capTensor_merge' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.omegaFun_tensor_oddPair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.colourMerge_coord' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.colourMerge_coord_oddPair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.coordOf_modelStarVec' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.evenBasisVec_split' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.evFormOdd' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.stdToOmega_one' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.stdToOmega_one_even' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.stdToOmega_one_odd' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.evenBasisVec_one' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.oddBasisVec_one' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.stdForm_evenPair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.stdForm_oddPair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.omegaFun_ev_basis' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.capVal_expansion' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.splitCapVal_expansion' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.splitCapVal_merge' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.capVal_succ' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.coordOf_evenBasisVec' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.splitCapVal_oddMerge' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.peelColour_spec' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.eq_peelColour_of' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.peelColour_isEven' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.pairing_starFlagEnum_symm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.powMerge_topBraid' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.wordSign_eq_oddInversions' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.toColour_topBraid' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.toColour_powBraid' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.toColour_powBraidWord' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### 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. +-/ + +/-- info: 'RS.wordPerm_adjWord' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.coordOf_modelPermMap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.coordOf_modelPermMap'' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.capVal_closed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.parameter_colour_sum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.starVec_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.stdFromOmega_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.starCoord_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.oddInversions_adjacent' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.starCoord_repeat_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.parameter_masterSummand' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.masterSum_partition' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.colourFlags_pairing_mem' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.colourFlags_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.card_even' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.colouringOf_isEven' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.colouringOf_diagonal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.blockRestrict_parity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.masterSummand_vanish_of_block_odd' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.masterSummand_vanish_of_not_eulerian' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.mem_colourFlags_iff' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.starFlagEnum_pairing_low' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.starFlagEnum_pairing_high' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.oddDataOf_constancy' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.evenDataOf_constancy' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.betaDiag_eq_betaColour' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.betaColour_perm'' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.masterSummand_vanish_of_impure' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.masterSummand_vanish_of_not_closed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.colouringOf_reconstruct' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.oddColouringOf_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.evenColouringOf_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.masterSummand_vanish_of_not_diagonal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.pairPure_of_pattern_closed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.fibreSum_eq_dataSum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.koszulCrossings_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.image_blockFlag' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.blockRestrict_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.blockRestrict_colouringOf_isRight' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.repFlag_pairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.outRepSet_pairing_mem' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.colourFormEntry_inr_partner' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.betaDiag_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.evenColoursAt_blockVertex' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.OddColouring.sum_flip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.blockRestrict_colouringOfFlip_mem' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.map_flagsAt_blockVertex' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.oddInversions_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.sortSign_ofFn_comp_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.prod_out_sign_eq_prod_edges' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.edge_sign_sector' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.oddListAt_coe_multiset' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.prod_oddSignAt' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.betaDiag_colouringOfFlip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- +info: 'RS.EdgeSubset.TransitionSystem.circuitCount_eq_orbitCount_outPerm' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.TransitionSystem.neg_one_pow_circuitCount' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.oddListAt_eq_map' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.pairFlagList_nodup' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.mem_blockOddFlagList_iff_pairFlagList' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.prod_blockVertex' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.sortSign_map_listIndexPerm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.sign_listIndexPerm_trans' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.sortSign_pairFlagList_key' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.exists_canonPerm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.oddListOf_blockRestrict' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.evenMultisetOf_blockRestrict' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.starCoord_block_flip_nodup' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.starCoord_block_flip_not_nodup' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.oddListOf_blockRestrict_eq_map' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.vertex_sign_collapse' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.patternOddInv_eq_inversions' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.sortSign_globalPairList' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.sign_listIndexPerm_slot_edge' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.sign_listIndexPerm_edge_oriented' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.hMaster_vertex_nodup' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.defFiveNF_eq_flip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.sign_listIndexPerm_oriented_matched' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.sign_listIndexPerm_matched_global' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.core_parity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.grand_parity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.masterSummand_colouringOfFlip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.fibreSum_eq' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.parameter_eq_mixedPartition' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.hMaster_colouringOfFlip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.mixedSummand_eq_nf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.eulerian_independence_closed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.mixedValue_eq_summand_closed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### Deligne's hypotheses for the envelope + +Each hypothesis of the cited theorem, discharged for the concrete +envelope, and the package they assemble into. +-/ + +/-- info: 'RS.env_deligneSemisimple' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.env_deligneGenerated' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.env_deligneModerateGrowth' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.env_delignePackage' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.skein_delignePackage' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### 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..3721d40cab --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintConverse.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 +-/ + +import LeanPool.RegtsSevenster.RS.Assembly.BlueprintSchur +import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopExample +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. +-/ + +/-- info: 'RS.EdgeSubset.pathMatch_eq_pairing_of_boundary' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +-- 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. + +/-- info: 'RS.EdgeSubset.boundaryFlag_chordInv' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.chordInv_mem' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.chordInv_invol' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.chordInv_ne' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +-- 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. + +/-- info: 'RS.EdgeSubset.boundaryLabel_boundaryFlag' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +-- 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. +-/ + +/-- info: 'RS.converse_of_superGram' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.converse_of_superGramIdentity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.exists_sum_sum_superForm_tFull' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.exists_sum_sum_superForm_tensorTermAt' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### 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. +-/ + +/-- info: 'RS.EdgeSubset.sign_composition_pair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.chainDir_pushData_alternates' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.edgeSum_closeBase_eq_pairAgreeValue' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.liftData' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.glueDataOpen' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.glueDataClosed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.match_unglue_glueDataOpen' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.isOut_unglue_glueDataOpen' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.match_unglue_glueDataClosed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.isOut_unglue_glueDataClosed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.edgeTermAt_pushData_colourSum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### 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. +-/ + +/-- info: 'RS.EdgeSubset.summandSum_bits_indep' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.baseSumBitsOf_all' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.baseSumIsClosure_all' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.superGramIdentity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.regts_sevenster_converse' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.regts_sevenster_iff' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.regts_sevenster_quant_roundtrip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### 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. +-/ + +/-- info: 'RS.mixedPartition_loopGraph' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.mixedPartition_loopGraphCircle' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintDeligne.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintDeligne.lean new file mode 100644 index 0000000000..f0effe779a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintDeligne.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 +-/ + +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. +-/ + +namespace RS + +/-! ### Deligne's theorem -/ + +/-- info: 'RS.deligne_theorem' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.braidedFibreHypothesis' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.exists_splitting_simple_algebra_doubled' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.exists_simple_quotient' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### The summit, unconditionally -/ + +/-- info: 'RS.regts_sevenster' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.regts_sevenster_quant' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.regts_sevenster_total' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.regts_sevenster_characterisation' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.regts_sevenster_quant_characterisation' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### Minimum dimensions, growth and padding -/ + +/-- info: 'RS.minimumColourDimension_le_of_represents' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.TotalBoundedMixedModel.dimension_eq_minimum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.stdModel_dimension_eq_minimum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.stdModel_connectionRank_growth' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.MixedColourEmbedding.mixedPartition_extendColours' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.MixedFunctional.padColours_represents' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.TotalBoundedMixedModel.even_dimension_eq' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.TotalBoundedMixedModel.half_odd_dimension_eq' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.regts_sevenster_minimum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.regts_sevenster_rank_growth' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.regts_sevenster_prescribed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintFactorial.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintFactorial.lean new file mode 100644 index 0000000000..5448f69a67 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintFactorial.lean @@ -0,0 +1,269 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.FactorialTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiSemisimple +import LeanPool.RegtsSevenster.RS.Novel.Envelope.ObjectTower +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. +-/ + +namespace RS + +/-! ### Statements -/ + +/-- info: @SinglePowerTrace : {A : Type u_1} → [inst : Ring A] → [inst_1 : Algebra ℂ A] → (A →ₗ[ℂ] ℂ) → A → Prop -/ +#guard_msgs in + +/-- info: @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 -/ +#guard_msgs in + +/-- info: 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) -/ +#guard_msgs in + +/-- info: @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 -/ +#guard_msgs in + +/-- info: @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) -/ +#guard_msgs in + +/-- info: @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 -/ +#guard_msgs in + +/-- info: @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 -/ +#guard_msgs in + +/-- info: @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 -/ +#guard_msgs in + +/-- info: @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 -/ +#guard_msgs in + +/-- info: @skeinTrace_eq_zero_of_isNilpotent_factorial : ∀ {R : ℕ} (f : EdgeRankParameter R) (n : ℕ) {g : skeinEnd f n}, + IsNilpotent g → skeinTrace f n g = 0 -/ +#guard_msgs in + +/-- info: @skeinEnd_isSemisimpleRing_factorial : ∀ {R : ℕ} (f : EdgeRankParameter R) (n : ℕ), IsSemisimpleRing (skeinEnd f n) -/ +#guard_msgs in + +/-- info: @karoubiEnd_isSemisimpleRing_factorial : ∀ {R : ℕ} (f : EdgeRankParameter R) + (X : CategoryTheory.Idempotents.Karoubi (SkeinObj f)), IsSemisimpleRing (CategoryTheory.End X) -/ +#guard_msgs in + +/-- info: @karoubiEnd_isSemisimpleRing : ∀ {R : ℕ} (f : EdgeRankParameter R) + (X : CategoryTheory.Idempotents.Karoubi (SkeinObj f)), IsSemisimpleRing (CategoryTheory.End X) -/ +#guard_msgs in + +/-- info: @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 -/ +#guard_msgs in + +/-- info: @envEnd_isSemisimpleRing : ∀ {R : ℕ} (f : EdgeRankParameter R) (E : Env f), IsSemisimpleRing (CategoryTheory.End E) -/ +#guard_msgs in + +/-- info: @envAbelian : {R : ℕ} → (f : EdgeRankParameter R) → CategoryTheory.Abelian (Env f) -/ +#guard_msgs in + +/-- info: @env_deligneSemisimple : ∀ {R : ℕ} (f : EdgeRankParameter R), IsSemisimple (Env f) -/ +#guard_msgs in + +/-- info: @env_delignePackage : ∀ {R : ℕ} (f : EdgeRankParameter R), DeligneTheoremStatement → Nonempty (DelignePackage (Env f)) -/ +#guard_msgs in + +/-- info: @skein_delignePackage : ∀ {R : ℕ} (f : EdgeRankParameter R), + DeligneTheoremStatement → Nonempty (DelignePackage (SkeinObj f)) -/ +#guard_msgs in + +/-! ### Axioms -/ + +/-- info: 'RS.exists_singlePowerTrace_pow' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.linearIndependent_of_group_trace' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.CycleTraceTower.factorial_le_finrank' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.CycleTraceTower.traceA_eq_zero_of_finrank_lt_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.CycleTraceTower.traceA_eq_zero_of_exponential_bound' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.scalarTrace_eq_zero_of_finrank_lt_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.scalarTrace_eq_zero_of_isNilpotent_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.skeinTrace_eq_zero_of_isNilpotent_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.skeinEnd_isSemisimpleRing_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.karoubiEnd_isSemisimpleRing_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.envAbelian' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### Independence from the appendix and fibre-functor engines -/ + +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..0ed7d23a71 --- /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 +-/ + +import LeanPool.RegtsSevenster.RS.Assembly.Blueprint +import LeanPool.RegtsSevenster.RS.Novel.Envelope.ObjectTower +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. +-/ + +/-- info: 'RS.jtChar_frobenius'' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.jtChar_orthonormal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.jtChar_eq_nChar' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.nProjector_block_faithful' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.square_growth' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.branching_of_pairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.jtChar_pad' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.schurPackageOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.restrPairing_ne_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.schurPackage' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### The forward theorem on Deligne alone -/ + +/-- info: 'RS.regts_sevenster_deligne_only' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### 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. +-/ + +/-- info: 'RS.FrobeniusTower.traceZeta_rational' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.FrobeniusTower.traceZeta_superSpectrum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.traceZeta_eq_newtonH_series' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### 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`. +-/ + +/-- info: 'RS.FrobeniusTower.traceZeta_rational_sharp' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.FrobeniusTower.traceZeta_superSpectrum_sharp' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.PermTower.hook_confinement_sharp' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.newtonH_series_rational_of_hook_vanishing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### 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 +-/ +#guard_msgs in + +/-- +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 +-/ +#guard_msgs in + +/-! ### 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. +-/ + +/-- info: 'RS.square_growth_sharp' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.PermTower.not_alive_square_sharp' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.skeinRep_square_dead' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.functional_charIdempotent_signed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.charIdempotent_image_ne_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.RelTransitionSystem.pathMatch_invol' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.superPermAction_square_dead' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.mixedPartition_empty' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.squareSectorBound_of_detPos' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.diagramSchur_square_const_ne_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.regts_sevenster_quant_of_detPos' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.squareBinomialDetPos' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.det_binomial_upper_ne_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.regts_sevenster_quant_deligne_only' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### 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. +-/ + +/-- info: 'RS.nDim_sq_le_finrank_of_projector_ne_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.finrank_le_mul_commutant' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.finrank_commutant_le_word_counts' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.le_of_pow_le_pow_mul_polynomial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.colourTotalEquiv_modelPermMap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.stdModel_total_dimension_le' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.regts_sevenster_total_deligne_only' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### 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. +-/ + +/-- info: 'RS.EdgeSubset.repair_connectivity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.eulerian_iff_parts' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.openCircuitCount_glueOpen_participating' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.pathCanonical_agree_nonperiodic' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.exists_pathCanonical' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.third_chord_reparity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.pairingConnectivity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.stepLedger_single' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.throughSummand_independence_of_allInternal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.twoPath_transform' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.pathMatch_repair_swap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.crossesCut_iff_chordPairCross' depends on axioms: [propext] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.pathSign_of_samePairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.signedValueAt_samePairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.pairedLedger_iff_value' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.signedValueAt_samePairing_of_value' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.TransposeVerify.not_throughIndependenceC' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.cutPartner_eq_some' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.eulerianIndependence' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.throughSummand_portFlip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.twoPathNonSep_transform' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.throughValueC_eq_signedValueAt' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.chainDir_pathMatch' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.pathCanonical_iff_chainDir' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.exists_recanonicalize' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.swap_dirs_opposite' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.mem_antiLowSet_transport_untouched' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.chainDir_true_iff_high' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.mem_antiLowSet_transport_of_canonical' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.pairedLedger_iff_unsigned' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.stateOddFlipSet_flipSet' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.mem_highSet_repair_end' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.chordCrossingCount_repair_parity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.fourLabel_parity_sep' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.fourLabel_parity_nonsep' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.flipSignProd_formula' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.flipSignProd_of_even' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.antiLowSet_transport_subset' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.symmU_trans' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.statusDiff_trans' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.statusDiff_of_samePairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.mem_pairFold_antiLow' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.antiLow_labels_eq_statusChange' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.antiLowSet_transport_eq' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.antiLowSet_transport_card' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.nonsep_labels_eq_statusChange' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.diagCrossCount_glue_cross' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.pairedLedgerUnsigned' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.pairedLedger' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.stepStatusLedger' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-- info: 'RS.EdgeSubset.chainStatusLedger' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in + +/-! ### 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] +-/ +#guard_msgs in + +/-- +info: 'RS.objectFrobeniusTower' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in + +/-- +info: 'RS.traceZeta_rational_of_object' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in + +/-- +info: 'RS.scalarTrace_eq_zero_of_isNilpotent' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in + +/-- +info: 'RS.traceZeta_superSpectrum_of_object' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in + +/-! ### 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 +-/ +#guard_msgs in + +/-- +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 +-/ +#guard_msgs in + +/-- +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) +-/ +#guard_msgs in diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean new file mode 100644 index 0000000000..876208d196 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopExample +import LeanPool.RegtsSevenster.RS.TheoremConverse +import LeanPool.RegtsSevenster.RS.TheoremForward +import LeanPool.RegtsSevenster.RS.TheoremQuant +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 `#guard_msgs` 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. +-/ + +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. -/ + +/-- info: Fragment : Type → Type 1 -/ +#guard_msgs in + +/-- info: ClosedFragment : Type 1 -/ +#guard_msgs in + +/-- info: emptyClosedFragment : ClosedFragment -/ +#guard_msgs in + +/-- info: @Fragment.Equiv : {α : Type} → Fragment α → Fragment α → Type -/ +#guard_msgs in + +/-! ## 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. -/ + +/-- info: MixedFunctional : ℕ → ℕ → Type -/ +#guard_msgs in + +/-- info: @mixedPartition : {α : Type} → {k ℓ : ℕ} → MixedFunctional k ℓ → Fragment α → ℂ -/ +#guard_msgs in + +/-- info: IsMixedPartitionFunction : (ClosedFragment → ℂ) → Prop -/ +#guard_msgs in + +/-- info: IsMixedPartitionFunctionBounded : (ClosedFragment → ℂ) → ℕ → Prop -/ +#guard_msgs in + +/-- info: TotalBoundedMixedModel : (ClosedFragment → ℂ) → ℕ → Type -/ +#guard_msgs in + +/-- info: IsMixedPartitionFunctionTotalBounded : (ClosedFragment → ℂ) → ℕ → Prop -/ +#guard_msgs in + +/-! The total bound is pinned by content: its witness bounds the +sum of both dimensions and evaluates to the original parameter. -/ + +/-- +info: 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 +-/ +#guard_msgs in + +/-- +info: def RS.IsMixedPartitionFunctionTotalBounded : (ClosedFragment → ℂ) → ℕ → Prop := +fun (f : ClosedFragment → ℂ) (B : ℕ) => Nonempty (TotalBoundedMixedModel f B) +-/ +#guard_msgs in + +/-! ## 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. -/ + +/-- info: EdgeRankBounded : (ClosedFragment → ℂ) → ℕ → Prop -/ +#guard_msgs in + +/-- info: EdgeRankParameter : ℕ → Type 1 -/ +#guard_msgs in + +/-! ## The statements and Deligne's theorem -/ + +/-- info: RegtsSevensterStatement : Prop -/ +#guard_msgs in + +/-- info: RegtsSevensterStatementQuant : Prop -/ +#guard_msgs in + +/-- info: RegtsSevensterStatementTotal : Prop -/ +#guard_msgs in + +/-- +info: def RS.RegtsSevensterStatementTotal : Prop := +∀ (R : ℕ) (f : EdgeRankParameter R), IsMixedPartitionFunctionTotalBounded f.val R +-/ +#guard_msgs in + +/-- info: RegtsSevensterConverseStatement : Prop -/ +#guard_msgs in + +/-- info: DeligneTheoremStatement : Prop -/ +#guard_msgs in + +/-! ### 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. +-/ + +/-- +info: 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) +-/ +#guard_msgs in + +/-- +info: 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 +-/ +#guard_msgs in + +/-- +info: 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 +-/ +#guard_msgs in + +/-- +info: 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) +-/ +#guard_msgs in + +/-- +info: 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 +-/ +#guard_msgs in + +/-- +info: 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) +-/ +#guard_msgs in + +/-- +info: 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 +-/ +#guard_msgs in + +/-- +info: 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) +-/ +#guard_msgs in + +/-- +info: 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 +-/ +#guard_msgs in + +/-- +info: 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) +-/ +#guard_msgs in + +/-! ## The theorems of record + +The converse carries no hypothesis; the forward direction and the +characterization carry Deligne's theorem and nothing else. -/ + +/-- info: regts_sevenster_converse : RegtsSevensterConverseStatement -/ +#guard_msgs in + +/-- info: regts_sevenster_deligne_only : DeligneTheoremStatement → RegtsSevensterStatement -/ +#guard_msgs in + +/-- +info: regts_sevenster_quant_deligne_only : DeligneTheoremStatement → RegtsSevensterStatementQuant +-/ +#guard_msgs in + +/-- info: regts_sevenster_total_deligne_only : DeligneTheoremStatement → RegtsSevensterStatementTotal -/ +#guard_msgs in + +/-- info: regts_sevenster_total : RegtsSevensterStatementTotal -/ +#guard_msgs in + +/-- +info: @edgeRankBounded_of_mixedBounded : ∀ {f : ClosedFragment → ℂ} {B : ℕ}, + IsMixedPartitionFunctionBounded f B → EdgeRankBounded f (max 1 (2 * B)) +-/ +#guard_msgs in + +/-- +info: 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) +-/ +#guard_msgs in + +/-- +info: 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)) +-/ +#guard_msgs in + +/-! ## 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. -/ + +/-- info: loopGraph : ClosedFragment -/ +#guard_msgs in + +/-- info: charPolyFunctional : ℂ → MixedFunctional 2 1 -/ +#guard_msgs in + +/-- info: mixedPartition_loopGraph : ∀ (θ : ℂ), mixedPartition (charPolyFunctional θ) loopGraph = θ - 2 -/ +#guard_msgs in + +/-- info: mixedPartition_loopGraphCircle : ∀ (θ : ℂ), mixedPartition (charPolyFunctional θ) loopGraphCircle = 0 -/ +#guard_msgs in + +/-! ## Minimum dimensions, rank growth and padding -/ + +/-- +info: circlesClosed : ℕ → ClosedFragment +-/ +#guard_msgs in + +/-- +info: connectionRank : (ClosedFragment → ℂ) → ℕ → ℕ +-/ +#guard_msgs in + +/-- +info: @MixedFunctional.Represents : {k ℓ : ℕ} → MixedFunctional k ℓ → (ClosedFragment → ℂ) → Prop +-/ +#guard_msgs in + +/-- +info: minimumColourDimension : (ClosedFragment → ℂ) → ℕ +-/ +#guard_msgs in + +/-- +info: PrescribedColourBounds : (ClosedFragment → ℂ) → ℕ → ℕ → Prop +-/ +#guard_msgs in + +/-- +info: @regts_sevenster_minimum : ∀ {R : ℕ} (f : EdgeRankParameter R), + IsMixedPartitionFunctionTotalBounded f.val (minimumColourDimension f.val) +-/ +#guard_msgs in + +/-- +info: @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)) +-/ +#guard_msgs in + +/-- +info: regts_sevenster_prescribed : ∀ (f : ClosedFragment → ℂ), + f emptyClosedFragment = 1 → + (∀ (W₁ W₂ : ClosedFragment) (a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → + ∀ (k ℓ : ℕ), (∃ h, h.Represents f) ↔ PrescribedColourBounds f k ℓ +-/ +#guard_msgs in + +/-- +info: regts_sevenster_minimum_deligne_only : DeligneTheoremStatement → + ∀ {R : ℕ} (f : EdgeRankParameter R), IsMixedPartitionFunctionTotalBounded f.val (minimumColourDimension f.val) +-/ +#guard_msgs in + +/-- +info: 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)) +-/ +#guard_msgs in + +/-- +info: 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, h.Represents f) ↔ PrescribedColourBounds f K L +-/ +#guard_msgs in + +/-- +info: @minimumColourDimension_le_of_represents : ∀ {f : ClosedFragment → ℂ} {k ℓ : ℕ} (h : MixedFunctional k ℓ), + h.Represents f → minimumColourDimension f ≤ k + 2 * ℓ +-/ +#guard_msgs in + +/-- +info: @TotalBoundedMixedModel.dimension_eq_minimum : ∀ {f : ClosedFragment → ℂ} + (M : TotalBoundedMixedModel f (minimumColourDimension f)), M.k + 2 * M.ℓ = minimumColourDimension f +-/ +#guard_msgs in + +/-- +info: @TotalBoundedMixedModel.even_dimension_eq : ∀ {f : ClosedFragment → ℂ} + (M : TotalBoundedMixedModel f (minimumColourDimension f)), + ↑M.k = (↑(minimumColourDimension f) + f (circlesClosed 1)) / 2 +-/ +#guard_msgs in + +/-- +info: @TotalBoundedMixedModel.half_odd_dimension_eq : ∀ {f : ClosedFragment → ℂ} + (M : TotalBoundedMixedModel f (minimumColourDimension f)), + ↑M.ℓ = (↑(minimumColourDimension f) - f (circlesClosed 1)) / 4 +-/ +#guard_msgs in + +/-- +info: @MixedFunctional.padColours : {k ℓ K L : ℕ} → MixedFunctional k ℓ → k ≤ K → ℓ ≤ L → MixedFunctional K L +-/ +#guard_msgs in + +/-- +info: @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 +-/ +#guard_msgs in + +/-- +info: @connectionRank_cast_eq_rank : ∀ {R : ℕ} (f : EdgeRankParameter R) (t : ℕ), + ↑(connectionRank f.val t) = Module.rank ℂ ↥(connectionMap f.val t).range +-/ +#guard_msgs in + +/-- +info: def RS.circlesClosed : ℕ → ClosedFragment := +fun c => (Fragment.circlesOnly c).relabel (Equiv.equivOfIsEmpty Empty (Fin 0)) +-/ +#guard_msgs in + +/-- +info: def RS.connectionRank : (ClosedFragment → ℂ) → ℕ → ℕ := +fun f t => Module.finrank ℂ ↥(connectionMap f t).range +-/ +#guard_msgs in + +/-- +info: def RS.MixedFunctional.Represents : {k ℓ : ℕ} → MixedFunctional k ℓ → (ClosedFragment → ℂ) → Prop := +fun {k ℓ} h f => ∀ (W : ClosedFragment), f W = mixedPartition h W +-/ +#guard_msgs in + +/-- +info: def RS.minimumColourDimension : (ClosedFragment → ℂ) → ℕ := +fun f => sInf {d | IsMixedPartitionFunctionTotalBounded f d} +-/ +#guard_msgs in + +/-- +info: 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 ℓ +-/ +#guard_msgs in + +end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical.lean b/LeanPool/RegtsSevenster/RS/Classical.lean new file mode 100644 index 0000000000..69be3a4149 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Algebra.TraceCriterion +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiLinear +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiTrace +import LeanPool.RegtsSevenster.RS.Classical.Algebra.FactorialTrace +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Growth +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Intertwine +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LengthBound +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LinearCategory +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.PartialTrace +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.TensorPow +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Trace +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneBridge +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackageRestrict +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneTheorem +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.FibreTransport +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.KoszulAction +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaPerm +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaTensorPower +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorDischarge +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorIntertwine +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.TotalDimension +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BlockKill +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BranchTrace +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CentralElem +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharClass +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharDecomp +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharEquiv +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourCycleSum +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CommutantBound +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ContentCount +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleFactor +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSum +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSumPrep +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.EndSum +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FibreCard +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FixWeight +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.HVal +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.IdempotentBridge +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTChar +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIntChar +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIrreducible +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTOrtho +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTPad +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTSimple +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.KillSimples +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedCount +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedFixed +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeAction +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.OrbitBridge +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.Package +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairChar +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairInner +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairOrbit +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairStab +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairTuple +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairingPos +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PermModule +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.RegularTrace +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SameCycleQuot +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ScalarTrace +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SchurAction +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SigmaCycleType +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignResolve +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignedTensor +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SimpleEmbed +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowth +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowthSharp +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareStair +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.StabCount +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorNonvanishing +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorTrace +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.WordCommutant +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourAction +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConj +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjStep +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjTop +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourEval +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourExtendSwap +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourFormMatch +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMerge +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMergeOdd +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairing +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairingSymm +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourTotal +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord +import LeanPool.RegtsSevenster.RS.Classical.Super.OrthonormalBasis +import LeanPool.RegtsSevenster.RS.Classical.Super.PowBraid +import LeanPool.RegtsSevenster.RS.Classical.Super.SuperVect +import LeanPool.RegtsSevenster.RS.Classical.Super.SymplecticBasis +import LeanPool.RegtsSevenster.RS.Classical.Super.TotalSpace +import LeanPool.RegtsSevenster.RS.Classical.Super.WordSignPerm +import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantExpand +import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantPieri +import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantStrict +import LeanPool.RegtsSevenster.RS.Classical.SymFun.Bialternant +import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialDet +import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialH +import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffExtract +import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffSplit +import LeanPool.RegtsSevenster.RS.Classical.SymFun.DeltaSeq +import LeanPool.RegtsSevenster.RS.Classical.SymFun.DescVandermonde +import LeanPool.RegtsSevenster.RS.Classical.SymFun.DimFormula +import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHConv +import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHDischarge +import LeanPool.RegtsSevenster.RS.Classical.SymFun.HInsert +import LeanPool.RegtsSevenster.RS.Classical.SymFun.HProdCoeff +import LeanPool.RegtsSevenster.RS.Classical.SymFun.HSubZ +import LeanPool.RegtsSevenster.RS.Classical.SymFun.HookVanishing +import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTDetExpand +import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTGuard +import LeanPool.RegtsSevenster.RS.Classical.SymFun.LGVStrict +import LeanPool.RegtsSevenster.RS.Classical.SymFun.PieriChain +import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowCount +import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums +import LeanPool.RegtsSevenster.RS.Classical.SymFun.RationalityFromRecurrence +import LeanPool.RegtsSevenster.RS.Classical.SymFun.RecurrenceFromVanishing +import LeanPool.RegtsSevenster.RS.Classical.SymFun.SubsetEH +import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums +import LeanPool.RegtsSevenster.RS.Classical.SymFun.TCount +import LeanPool.RegtsSevenster.RS.Classical.SymFun.TIdentity +import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaExp +import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaRational +import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaSeries +import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid +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..d5d1da07e4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Algebra/FactorialTrace.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 +-/ + +import LeanPool.RegtsSevenster.RS.Common.NilpotentPowerTrace +import LeanPool.RegtsSevenster.RS.Common.TraceSeparation +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`. +-/ + +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 [if_neg 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..1d576d92f3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Algebra/TraceCriterion.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 +-/ + +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`. + +-/ + +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 + haveI : 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..01c87e4731 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Growth.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 +-/ + +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. +-/ + +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] [Abelian A] [HasFiniteBiproducts 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 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..6e849765dc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Intertwine.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 +-/ + +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. +-/ + +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..ad6386444f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiLinear.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 +-/ + +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. +-/ + +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 + show (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 + show 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..a95aee8065 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiTrace.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiLinear +import LeanPool.RegtsSevenster.RS.Classical.Algebra.TraceCriterion +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. +-/ + +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 + haveI : 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..28593f2b4c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Length.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 +-/ + +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. +-/ + +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 + haveI := 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 _ + haveI : 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] + haveI : Epi (Subobject.ofLE P Q hPQ) := + Preadditive.epi_of_cokernel_zero hcz + haveI : 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..90de433d60 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LengthBound.lean @@ -0,0 +1,196 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length +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. +-/ + +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 => + haveI := 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 [if_pos rfl, Linear.smul_comp, hidem] + · rw [if_neg 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, if_pos (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 + haveI := 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 + haveI : 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] + [Abelian C] [HasFiniteBiproducts 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 + letI : Abelian C := abelianOver + 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..cb9c00f905 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LinearCategory.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 +-/ + +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`. +-/ + +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..207c8a85af --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/PartialTrace.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 +-/ + +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. +-/ + +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 + show (ρ_ 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 + show (ρ_ 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 + show (ρ_ (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 + show (ρ_ 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] + show η_ (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..3a570ded2a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/TensorPow.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 +-/ + +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. +-/ + +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..69e1d7eff8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Trace.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 +-/ + +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. +-/ + +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 + show η_ 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 + show η_ 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 + show η_ 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 + show η_ 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 + letI := p₁ + letI := 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) + show η_ 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)] + show η_ (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] + show (ρ_ (𝟙_ 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..b4d175bfc3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/UnitEnd.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 +-/ + +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. +-/ + +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..f0ad6d889e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/WhiskerAdditive.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 +-/ + +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. +-/ + +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..3b2f88b014 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPowAct +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeAdjoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeCoherence +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeFree +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeLinear +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeZigzag +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensorUnit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodTransfer +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BlockUnits +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BraidCoherence +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGr +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGraded +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGradedLaws +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBInd +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBNonzero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBofA +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBridge +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainDelta +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.Base +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.FirstSlot +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.SecondSlot +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMul +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulHet +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainNonzero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainShift +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainStage2 +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainUnit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CharSplit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CommonAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoprodPreserve +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescent +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescentClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableNullstellensatz +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoverFactor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CycleSplit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayCalculus +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayType +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DeligneAssembly +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DescentClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DevissageBound +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledAbelian +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledGrowth +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledLine +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledScalar +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSmall +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSplit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DualityMate +import LeanPool.RegtsSevenster.RS.Classical.Deligne.EvenEmbedMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ExactFromShort +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FactorialBeats +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreBridge +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreEps +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreExact +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFaithful +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFunctor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMix +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMu +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreLinear +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMuNat +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverComplex +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverSplitting +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreRestrict +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreStrong +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FiltNil +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FlatLimit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeCollapseAlg +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeMixRetract +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModAdjoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModFunctor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffleCoh +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSummand +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormalise +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseBase +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseStep +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowDesc +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowInsert +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSlide +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeTwistPi +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaCountable +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaComplex +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairAdd +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeFree +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeMix +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetract +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetractRight +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairUnit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaShift +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaTwistLeft +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GeneratorAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GrowthDichotomy +import LeanPool.RegtsSevenster.RS.Classical.Deligne.HomFinite +import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookMult +import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookZero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdemCut +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdempotentLength +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ImageSubalgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndAllColim +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndBigTensorUnit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCoeq +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCompact +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndDayClosure +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndImage +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndKill +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndLocallyMixed +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfLinear +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndPointTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchurKilled +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSimple +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplitSection +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndUnitNonzero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitState +import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KernelPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaData +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KillerNonempty +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KronKill +import LeanPool.RegtsSevenster.RS.Classical.Deligne.LambdaCoend +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixDegenerate +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffleLine +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixSumPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhisker +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhiskerAll +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedConc +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedDiag +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedTransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAssoc +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAbelian +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModContractL +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModCross +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModDual +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModIns +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMulti +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMultiTriple +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowCast +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescent +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescentClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowStage +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchur +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchurSummand +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModZero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MulBy +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MuInterchange +import LeanPool.RegtsSevenster.RS.Classical.Deligne.NatChain +import LeanPool.RegtsSevenster.RS.Classical.Deligne.NewtonConv +import LeanPool.RegtsSevenster.RS.Classical.Deligne.NullPoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLineMap +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddParity +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddPermSign +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquare +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquareIso +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairCarrier +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairMul +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairPerm +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermNat +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermRepChar +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PlainShuffle +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointBaseChange +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointFibre +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Calculus +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Coherence +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Comparison +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Functor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Residue +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowActMul +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowInduct +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowMerge +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairSucc +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairing +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSucc +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSuccMod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowTriangle +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZig +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZigzag +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PresentedQuotient +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21 +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21Core +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21General +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29Close +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Bridge +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Chain +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Close +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Ind +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Reduce +import LeanPool.RegtsSevenster.RS.Classical.Deligne.RegularSum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoTwist +import LeanPool.RegtsSevenster.RS.Classical.Deligne.RowColIdem +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichMerge +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichZig +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarBraiding +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitEquiv +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitInd +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurTransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SeedIns +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeFintype +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SignConj +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleGenerator +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SmallReduction +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleSplit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimplePoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleScalars +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAdjoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitClosure +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitEverything +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAssemble +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitComplement +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExact +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtract +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtractDual +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitMonHom +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitPairDef +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitReduce +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitTransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplittingAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.StateTransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepA +import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepATransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepB +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Letters +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Signs +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Standard +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEvenRing +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGamma +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGammaInst +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModAbelian +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprodMap +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModIso +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShift +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShiftUnit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperPointMod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperRealize +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSeries +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSmall +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperValues +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperVectSchur +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorPowZero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorTransfer +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorZigzag +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TrichotomyClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistCoherence +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistFreeTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistMixLine +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistShuffle +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistState +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistSymPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistUnitor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitBase +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitFreeMod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitMod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitStage +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UniversalAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.WhiskerFaithful +import LeanPool.RegtsSevenster.RS.Classical.Deligne.WordMap +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZagAction +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagNonzero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagSandwich +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransfer +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..33c5b708f1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPow.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 +-/ + +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`. +-/ + +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..afe1533625 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPowAct.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow +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. +-/ + +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..f30a11e301 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean @@ -0,0 +1,807 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTransport +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. +-/ + +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] + refine Eq.trans ((reassoc_of% + (projFormula_tensorμ_cover A B φ M' M)) _) ?_ + 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 + show ((β_ 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 hbk : (B ◁ (modTensorπ A M' M ≫ d.pair ≫ φ)) ≫ μ[B] = + (β_ B (M'.X ⊗ M.X)).hom ≫ + ((modTensorπ A M' M ≫ d.pair ≫ φ) ▷ B) ≫ μ[B] := by + rw [← BraidedCategory.braiding_naturality_right_assoc, + IsCommMonObj.mul_comm] + 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 + letI := 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 _ _ _ + refine Eq.trans (whisker_eq _ ((reassoc_of% 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)) _)) ?_ + rw [← 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..79a07278f7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeBiprod.lean @@ -0,0 +1,391 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show (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 + show (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, + MonoidalCategory.id_tensorHom] + rw [← MonoidalCategory.whiskerLeft_comp_assoc] + show 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, + MonoidalCategory.id_tensorHom] + rw [← MonoidalCategory.whiskerLeft_comp_assoc] + show 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' + · rw [Category.comp_id, biprod.inl_desc_assoc] + apply biprod.hom_ext + · rw [Category.assoc, biprod.lift_fst, biprod.inl_fst] + exact map_inl_fst A B φ M N + · rw [Category.assoc, biprod.lift_snd, biprod.inl_snd] + exact map_inl_snd A B φ M N + · rw [Category.comp_id, biprod.inr_desc_assoc] + apply biprod.hom_ext + · rw [Category.assoc, biprod.lift_fst, biprod.inr_fst] + exact map_inr_fst A B φ M N + · rw [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 + rw [biprod.lift_desc] + apply modTensor_hom_ext + show 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, + MonoidalCategory.id_tensorHom] + rw [← 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..c0f15bd808 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean @@ -0,0 +1,827 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum +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. +-/ + +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] + simp only [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 + show (β_ (baseChange φ M) A).hom ≫ + modTensorAct A (restrictRegular φ) M = _ + rw [← h] + show (β_ (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 + show ((β_ 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] + simp only [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 + show (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)] + rw [← MonoidalCategory.whiskerLeft_comp, hcov, + MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + 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] + simp only [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] + +/-- 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] + simp only [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] + +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..c5fc328478 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeDatum.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeLinear +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. +-/ + +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 + show 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' + show μ[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..6ac00e47e2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeFree.lean @@ -0,0 +1,354 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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] + rw [← whisker_exchange_assoc, baseChangeFree_balance] + simp only [Category.assoc] + rw [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..477ab7a790 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeLinear.lean @@ -0,0 +1,596 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTensor +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. +-/ + +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] + 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 + show 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..551e39631a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeMonoidal.lean @@ -0,0 +1,614 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeCoherence +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. +-/ + +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 [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 [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] + 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 + refine Eq.trans ((reassoc_of% + (projFormula_tensorμ_cover A B φ + (modTensorMod A M N) P)) _) ?_ + 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] + 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 + simp only [← 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))) + simpa only [Category.assoc] using 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..1527027ed2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTensor.lean @@ -0,0 +1,713 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAssoc +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. +-/ + +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 + show (β_ 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. -/ +@[reassoc (attr := simp)] +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 + rw [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 + rw [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..54f02dc1b6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTransport.lean @@ -0,0 +1,634 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeZigzag +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. +-/ + +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 + show 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 + show 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 + show (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 + show (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..384e8aa6b4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeZigzag.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 +-/ + +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. +-/ + +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..7154aa5c6f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensor.lean @@ -0,0 +1,1181 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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, dif_pos 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, dif_neg 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 + haveI := isMonHom_inclFilter B p l + haveI : 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] + haveI : 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] + haveI : 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 simp + | 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 + +/-- 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 simp + | 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] + haveI : 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]) + haveI : 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 + rw [ι_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 + rw [ι_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 + show (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 + show (tensorRight (finTensor B t)).map + (colimit.ι (finTensorDiagram B) s) ≫ bigTensorMulStage B t = + finTensorMul B s t ≫ bigTensorStage B (s ∪ t) + rw [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 + show (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 + show (tensorLeft (bigTensor B)).map + (colimit.ι (finTensorDiagram B) t) ≫ bigTensorMul B = + bigTensorMulStage B t + rw [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 + rw [ι_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 + show (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 + show (tensorLeft (finTensor B s)).map + (colimit.ι (finTensorDiagram B) t) ≫ bigTensorMulStageL B s = + finTensorMul B s t ≫ bigTensorStage B (s ∪ t) + rw [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] + haveI : 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 + show (β_ (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..a52836b80e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensorUnit.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 +-/ + +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. +-/ + +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..41738c1fa6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodPow.lean @@ -0,0 +1,1418 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedConc +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. +-/ + +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] + show 𝟙 (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 => + show 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 + show 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 + rw [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 => + show 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 + rw [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 + rw [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 + rw [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] + simp only [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 + rw [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..1afb1bd0b0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodTransfer.lean @@ -0,0 +1,337 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndKill +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). +-/ + +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 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 (X ⊞ Y) n (sortPerm w) ≫ + permMor (X ⊞ Y) n (sortPerm w)⁻¹ = 𝟙 _ := by + rw [show permMor (X ⊞ Y) n (sortPerm w) ≫ + permMor (X ⊞ Y) n (sortPerm w)⁻¹ = + permAlg (X ⊞ Y) n (MonoidAlgebra.single ((sortPerm w)⁻¹ * + sortPerm w) 1) from by + rw [show MonoidAlgebra.single ((sortPerm w)⁻¹ * + sortPerm w) (1 : ℂ) = + MonoidAlgebra.single (sortPerm w)⁻¹ 1 * + MonoidAlgebra.single (sortPerm w) 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 + 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 + rw [Shape.e, 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..d400305826 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BlockUnits.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful +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. +-/ + +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] + [Fintype 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 + 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 + haveI := 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 + show 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] [Fintype G] + [DecidableEq G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) : + Function.Surjective (nPsi S) := by + 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 + haveI := hS + haveI := IsSimpleModule.nontrivial + (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) S + haveI : 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 + show (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⟩, ?_⟩ + show 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..90718afb61 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BraidCoherence.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 +-/ + +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. +-/ + +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..2533161458 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainAlgebra.lean @@ -0,0 +1,780 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show (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 + show (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) + rw [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 + rw [ι_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 + rw [ι_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 + show (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 + show (tensorLeft (chainColimit B δ)).map + (colimit.ι (chainDiagram B δ) + (smallNatEquiv.functor.obj j)) ≫ + chainColimitMul B δ mu hδl hδr = + chainMulStage B δ mu hδl j + rw [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 + show (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 + show (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) + rw [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 + rw [ι_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..c9c6ff7351 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainB.lean @@ -0,0 +1,332 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra +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. +-/ + +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..cfc29cf170 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean @@ -0,0 +1,1603 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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.ι_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 + show (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) + rw [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 + show (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 + rw [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 + +-- Raised budget: 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 + +-- Raised budget: 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 + show (β_ (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 + rw [ι_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 + rw [ι_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 + +-- Raised budget: 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 + +-- Raised budget: 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 + rw [ι_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 + +-- Raised budget: 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 + +-- Raised budget: 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..16ee7411e7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean @@ -0,0 +1,568 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulHet +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. +-/ + +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 + show 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 + show 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' _ _ + +-- Raised budget: the graded comparison isomorphism is built from +-- the colimit cocone and the duality datum in one term. +/-- **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') + (fun k => by + show chainDelta2 A M M' d (0 + k) (0 + k) ≫ + chainStage2Cast A M M' (Nat.zero_add (k + 1)) + (Nat.zero_add (k + 1)) = + chainStage2Cast A M M' (Nat.zero_add k) + (Nat.zero_add k) ≫ + chainDelta2 A M M' d k k + exact (chainStage2Cast_delta2 A M M' d + (Nat.zero_add k) (Nat.zero_add k)).symm) + +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' _ _ + +-- Raised budget: the graded comparison isomorphism is built from +-- the colimit cocone and the duality datum in one term. +/-- **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₀) + (fun k => by + show chainDelta2 A M M' d (p₀ + 1 + k) (q₀ + 1 + k) ≫ + chainStage2Cast A M M' + (by omega : p₀ + 1 + (k + 1) = p₀ + (k + 1 + 1)) + (by omega : q₀ + 1 + (k + 1) = q₀ + (k + 1 + 1)) = + chainStage2Cast A M M' + (by omega : p₀ + 1 + k = p₀ + (k + 1)) + (by omega : q₀ + 1 + k = q₀ + (k + 1)) ≫ + chainDelta2 A M M' d (p₀ + (k + 1)) (q₀ + (k + 1)) + rw [chainStage2Cast_delta2 A M M' d + (by omega : p₀ + 1 + k = p₀ + (k + 1)) + (by omega : q₀ + 1 + k = q₀ + (k + 1))])) ≪≫ + 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 + show (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 + show (tensorLeft M'.X).map (colimit.ι (chainDiagram _ _) + (smallNatEquiv.functor.obj k)) ≫ _ = _ + rw [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..cb12d46cde --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGradedLaws.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 +-/ + +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`. +-/ + +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..7550479b89 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBInd.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB +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`. +-/ + +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..d0838d730f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBNonzero.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBInd +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. +-/ + +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..b8a4319e33 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBofA.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB +import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct +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. +-/ + +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) + rw [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..8aeff027d7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBridge.lean @@ -0,0 +1,493 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 -/ + +/-- **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 : 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 + show 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 + 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 + show 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 + rw [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 + rw [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 + rw [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 + rw [← 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 + rw [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)) + (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..f5651cabea --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainDelta.lean @@ -0,0 +1,173 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMul +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. +-/ + +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 + show 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 + rw [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] + show ((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..caea32641f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns.lean @@ -0,0 +1,18 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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..e732afef24 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/Base.lean @@ -0,0 +1,643 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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] + show (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] + show 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) + rw [reassoc_of% hM, reassoc_of% hN, hcond] + simp only [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] + show 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)) + rw [reassoc_of% hM, reassoc_of% hN, hcond] + simp only [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..89f39251f0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/FirstSlot.lean @@ -0,0 +1,1054 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + +/-- **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 ?_ + show (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 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 + rw [← 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] + simp only [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 + rw [← 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. + 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₀ := + ((reassoc_of% hα1) + ((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₀)).trans + (Category.assoc _ _ _) + 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 + rw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, + Category.id_comp] + simp only [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) + (((reassoc_of% + (tensorHom_π_chainMul2 A M M' (p + 1) q r s)) + (chainStage2Cast A M M' hp₀ hq₀)).trans + ((Category.assoc _ _ _).trans + (congrArg (CategoryStruct.comp _) + (Category.assoc _ _ _)))) + 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 + rw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, + MonoidalCategory.tensorHom_comp_tensorHom_assoc] + 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 + show (((α_ 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 (l1.trans (l2.trans (l3.trans (l4.trans + (l5.trans l6))))).trans + (r1.trans (r2.trans (r3.trans (r4.trans (r5.trans + (r6.trans (r7.trans (r8.trans r9)))))))).symm + +/-- **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 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`. + 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. + 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 (l1.trans (l2.trans (l3.trans (l4.trans (c1.trans + (c2.trans (c3.trans (c4.trans c5)))))))).trans + (b1.trans (b2.trans (b3.trans (b4.trans (b5.trans + (b6.trans b7)))))).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..7226aab07a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/SecondSlot.lean @@ -0,0 +1,1255 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + +/-- **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 ?_ + show (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 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 + rw [← 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] + simp only [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)) + 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. + 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₀ := + ((reassoc_of% hα1) + ((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₀)).trans + (Category.assoc _ _ _) + 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 + rw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, + Category.id_comp] + simp only [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 ≫ + ((β_ 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) + (((reassoc_of% + (tensorHom_π_chainMul2 A M M' p (q + 1) r s)) + (chainStage2Cast A M M' hp₀ hq₀)).trans + ((Category.assoc _ _ _).trans + (congrArg (CategoryStruct.comp _) + (Category.assoc _ _ _)))) + 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 + 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 + rw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, + MonoidalCategory.tensorHom_comp_tensorHom_assoc] + 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 + show ((((α_ 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) + simp only [Category.assoc] + rw [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 (l1.trans (l2.trans (l3.trans (l4.trans + (l5.trans l6))))).trans + (r1.trans (r2.trans (r3.trans (r4.trans (r5.trans + (r6.trans (r7.trans (r8.trans r9)))))))).symm + +/-- **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 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] + 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) ≫ + 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`. + 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. + 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 (l1.trans (l2.trans (l3.trans (l4.trans (c1.trans + (c2.trans (c3.trans (c4.trans c5)))))))).trans + (b1.trans (b2.trans (b3.trans (b4.trans (b5.trans + (b6.trans b7)))))).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..749a727170 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMul.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 +-/ + +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. +-/ + +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] + show (((β_ (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 + show (α_ 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) + show 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 ?_ + rw [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] + show ((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..eda1976705 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulHet.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 +-/ + +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. +-/ + +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 + show (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 + show (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) + rw [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 + show (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 + show (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 + rw [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..e5b2e56ed0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulLaws.lean @@ -0,0 +1,961 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMul +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`. +-/ + +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 + +/-- **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 + 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₂) + 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 + +/-- **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 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 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 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. + 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 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 (l1.trans (l2.trans (l3.trans (l4.trans + (l5.trans l6))))).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..c2c1fe086f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainNonzero.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBridge +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. +-/ + +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 + rw [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..57f24fdf8e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainShift.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 +-/ + +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. +-/ + +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 + show 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..f74552e6e8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainStage2.lean @@ -0,0 +1,1128 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws +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. +-/ + +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) + show 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 ?_ + rw [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] + show ((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 + +/-- **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 + 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₂) + 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 + +/-- **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 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 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 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. + 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 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 (l1.trans (l2.trans (l3.trans (l4.trans + (l5.trans l6))))).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..350c769ca8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainUnit.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.NatChain +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. +-/ + +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..948299b910 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CharSplit.lean @@ -0,0 +1,405 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.RegularSum +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. +-/ + +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ρν + haveI : ρμ.IsIrreducible := + isIrreducible_comp_permCastHom μ.prop.symm _ + (rhoS_isIrreducible _ (jtSimple_simple μ.val)) + haveI : ρν.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 + haveI : 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 [if_neg 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 + show symCast (le_of_eq μ.prop) (P.e μ.val) π = + P.e μ.val ((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.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 + haveI : 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..b565db81d7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CommonAlgebra.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 +-/ + +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. +-/ + +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 + letI : DecidableRel (WellOrderingRel (α := ι)) := + Classical.decRel _ + letI : 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..6fabe366ed --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoprodPreserve.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 +-/ + +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. +-/ + +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 + show ((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.ι_desc, + Sigma.ι_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 + haveI : HasCoproduct f := + HasColimit.mk (liftToFinsetColimitCocone (Discrete.functor f)) + haveI : 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 + show ((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.ι_desc_assoc, ι_comp_sigmaComparison, + stage_ι_comp_assoc, ← G.map_comp, Sigma.ι_desc] + rfl } + haveI : IsIso m := hD2.hom_isIso hD' m + haveI : 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 + haveI := 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..0e73cdc537 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescent.lean @@ -0,0 +1,885 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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 + rw [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 + rw [Category.assoc, colimit.w, hu'] + have hv2 : (v' ≫ (AsSmall.down ⋙ imageSeq A i₀).map htk) ≫ + colimit.ι (AsSmall.down ⋙ imageSeq A i₀) ⟨k⟩ = v := by + rw [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) + haveI : 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..180a89b71b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescentClose.lean @@ -0,0 +1,584 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ImageSubalgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndImage +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`. +-/ + +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 + show (λ_ 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 + letI := hmon + letI := 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) + haveI := hjunit + haveI := mono_imageSubalgebraHom_whiskerRight A j X + haveI := 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 + letI := hmon + letI := hcomm + obtain ⟨j, hjunit, t, ht⟩ := exists_imageSubalgebra_single A hW + (freeModHomEquiv A W (freeMod A V) s) + haveI := hjunit + haveI := 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..ef31b42ca1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableNullstellensatz.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 +-/ + +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. +-/ + +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 + haveI := hm + letI := Ideal.Quotient.field m + haveI : 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 + haveI : 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..37c9474cae --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoverFactor.lean @@ -0,0 +1,408 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PlainShuffle +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. +-/ + +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 + rw [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] + show 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) + rw [← 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) + +/-- **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] + show 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 : ((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)))))))) + 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 ?_ + 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..ed04e08bdd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CycleSplit.lean @@ -0,0 +1,509 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + letI : 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 [DecidableEq α] + {π : Equiv.Perm α} {s : Finset α} + (hs : ∀ x ∈ s, π x ∈ s) : ∀ x, π x ∈ s ↔ x ∈ s := by + 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, dif_pos 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..e6ec846e69 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayCalculus.lean @@ -0,0 +1,337 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show 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) = _ + rw [comp_natTrans, Functor.whiskerLeft_comp, ← Category.assoc, + coyonedaEquiv_comp] + rfl + +/-- 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 + haveI : PreservesColimitsOfSize.{v, v} + ((tensor D).lan (H := Type v)) := + ((tensor D).lanAdjunction (Type v)).leftAdjoint_preservesColimits + haveI : 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 + haveI : PreservesColimitsOfSize.{v, v} + ((tensor D).lan (H := Type v)) := + ((tensor D).lanAdjunction (Type v)).leftAdjoint_preservesColimits + haveI : 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..86635bfb7c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayType.lean @@ -0,0 +1,382 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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..ebd28e5be5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DeligneAssembly.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSplit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreLinear +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. +-/ + +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 + show (λ_ 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 + letI := linearOfScalarUnit (doubledScalarUnit hu) + letI := monoidalLinearOfScalarUnitBraided (doubledScalarUnit hu) + letI := linearOfScalarUnit (indScalarUnit (doubledScalarUnit hu)) + letI := monoidalLinearOfScalarUnitBraided + (indScalarUnit (doubledScalarUnit hu)) + obtain ⟨𝔹, hmon, hcomm, hne, hsimple, hsp, ⟨pt⟩⟩ := + exists_splitting_simple_algebra_doubled P P₀ hu X hgen hgrow + letI := hmon + letI := hcomm + haveI hpm : ∀ Z : Ind (Doubled B), + (tensorRight Z).PreservesMonomorphisms := fun _ => inferInstance + haveI 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 + haveI := (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) + letI := indOf_additive (C := Doubled B) + letI := indOfFunctorLinear (doubledScalarUnit hu) + letI := 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..37fd679389 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DescentClose.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichZig +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescentClose +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. +-/ + +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..e8761c1410 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DevissageBound.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormalise +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchurSummand +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhiskerAll +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. +-/ + +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 + letI := st.monObj + letI := 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..fac9fb0664 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledAbelian.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 +-/ + +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. +-/ + +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..0282965129 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledGrowth.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.TensorPow +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. +-/ + +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 + haveI := hi + haveI := hp + haveI : IsSplitMono s' := IsSplitMono.mk' ⟨r', hsr'⟩ + haveI : 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} [Fintype J] {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..4be8a665a5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledLine.lean @@ -0,0 +1,37 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling +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. +-/ + +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..2d3cc511b9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledScalar.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling +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. +-/ + +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..ca39d7fafa --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSmall.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 +-/ + +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. +-/ + +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..a7ecf85483 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSplit.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitEverything +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. +-/ + +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 + letI := linearOfScalarUnit (doubledScalarUnit hu) + letI := monoidalLinearOfScalarUnitBraided (doubledScalarUnit hu) + letI := linearOfScalarUnit (indScalarUnit (doubledScalarUnit hu)) + letI := 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..3f33bc3ebd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Doubling.lean @@ -0,0 +1,1755 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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. -/ +def 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. -/ +def 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. -/ +def 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 + +/-- 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 {X Y Z} := by + ext + · show 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 + · show 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 + zero_whiskerRight {X Y Z} := by + ext + · show 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 + · show 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 + · show 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 + · show 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 + · show 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 + · show 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 + · show 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 + · show 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 + · show 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 + · show 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, assocOdd] + · simp [braidingEven, braidingOdd, assocEven, assocOdd, + Preadditive.neg_comp, Preadditive.comp_neg] + show (α_ X.odd Y.odd Z.even).hom ≫ + X.odd ◁ biprod.inr ≫ + (-(β_ X.odd + (Y.even ⊗ Z.odd ⊞ Y.odd ⊗ Z.even)).hom) ≫ + descRight + ((α_ Y.even Z.odd X.odd).hom ≫ + Y.even ◁ biprod.inr ≫ biprod.inl) + ((α_ Y.odd Z.even X.odd).hom ≫ + Y.odd ◁ biprod.inl ≫ biprod.inr) = + -((β_ X.odd Y.odd).hom ▷ Z.even ≫ + (α_ Y.odd X.odd Z.even).hom ≫ + Y.odd ◁ (β_ X.odd Z.even).hom ≫ + Y.odd ◁ biprod.inl ≫ biprod.inr) + simp [Preadditive.neg_comp, Preadditive.comp_neg] + · apply tensorRight_ext + · simp [braidingEven, braidingOdd, assocEven, assocOdd] + · simp [braidingEven, braidingOdd, assocEven, assocOdd, + Preadditive.neg_comp, Preadditive.comp_neg] + show (α_ X.odd Y.even Z.odd).hom ≫ + X.odd ◁ biprod.inl ≫ + (-(β_ X.odd + (Y.even ⊗ Z.odd ⊞ Y.odd ⊗ Z.even)).hom) ≫ + descRight + ((α_ Y.even Z.odd X.odd).hom ≫ + Y.even ◁ biprod.inr ≫ biprod.inl) + ((α_ Y.odd Z.even X.odd).hom ≫ + Y.odd ◁ biprod.inl ≫ biprod.inr) = + -((β_ X.odd Y.even).hom ▷ Z.odd ≫ + (α_ Y.even X.odd Z.odd).hom ≫ + Y.even ◁ (β_ X.odd Z.odd).hom ≫ + Y.even ◁ biprod.inr ≫ biprod.inl) + simp [Preadditive.neg_comp, Preadditive.comp_neg] + · apply biprod.hom_ext' <;> apply tensorRight_ext <;> + simp [braidingEven, braidingOdd, assocEven, 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, assocOdd] + · simp [braidingEven, braidingOdd, assocEven, assocOdd, + Preadditive.neg_comp, Preadditive.comp_neg] + show (α_ X.even Y.odd Z.odd).inv ≫ + biprod.inl ▷ Z.odd ≫ + (-(β_ (X.even ⊗ Y.odd ⊞ X.odd ⊗ Y.even) + Z.odd).hom) ≫ + descLeft + ((α_ Z.odd X.even Y.odd).inv ≫ + biprod.inr ▷ Y.odd ≫ biprod.inr) + ((α_ Z.odd X.odd Y.even).inv ≫ + biprod.inr ▷ Y.even ≫ biprod.inl) = + -(X.even ◁ (β_ Y.odd Z.odd).hom ≫ + (α_ X.even Z.odd Y.odd).inv ≫ + (β_ X.even Z.odd).hom ▷ Y.odd ≫ + biprod.inr ▷ Y.odd ≫ biprod.inr) + simp [Preadditive.neg_comp, Preadditive.comp_neg] + · apply tensorLeft_ext + · simp [braidingEven, braidingOdd, assocEven, assocOdd, + Preadditive.neg_comp, Preadditive.comp_neg] + show (α_ X.odd Y.even Z.odd).inv ≫ + biprod.inr ▷ Z.odd ≫ + (-(β_ (X.even ⊗ Y.odd ⊞ X.odd ⊗ Y.even) + Z.odd).hom) ≫ + descLeft + ((α_ Z.odd X.even Y.odd).inv ≫ + biprod.inr ▷ Y.odd ≫ biprod.inr) + ((α_ Z.odd X.odd Y.even).inv ≫ + biprod.inr ▷ Y.even ≫ biprod.inl) = + -(X.odd ◁ (β_ Y.even Z.odd).hom ≫ + (α_ X.odd Z.odd Y.even).inv ≫ + (β_ X.odd Z.odd).hom ▷ Y.even ≫ + biprod.inr ▷ Y.even ≫ biprod.inl) + simp [Preadditive.neg_comp, Preadditive.comp_neg] + · simp [braidingEven, braidingOdd, assocEven, assocOdd] + · apply biprod.hom_ext' <;> apply tensorLeft_ext <;> + simp [braidingEven, braidingOdd, assocEven, 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 + · show 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 + · show 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)`. -/ +def 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 + · exact (isZero_zero A).eq_of_src _ _ + +/-- 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 + · exact (isZero_zero A).eq_of_src _ _ + +/-- 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 + · show biprod.map (β_ X Y).hom (-(β_ (0 : A) (0 : A)).hom) ≫ + biprod.fst = biprod.fst ≫ (β_ X Y).hom + simp + · exact (isZero_zero A).eq_of_tgt _ _ + +/-- 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. -/ +def 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 + · show 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 + · show biprod.fst ≫ biprod.inl + biprod.snd ≫ biprod.inr = + 𝟙 (X.even ⊞ Y.even) + exact biprod.total + · show 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 + · show 𝟙 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 + · show (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 + · exact (isZero_zero A).eq_of_src _ _ + · -- (inl, snd) + ext + · exact (isZero_biprod (isZero_zeroTensor _) + (isZero_tensorZero _)).eq_of_tgt _ _ + · exact (isZero_zero A).eq_of_src _ _ + · -- (inr, fst) + ext + · exact (isZero_biprod (isZero_zeroTensor _) + (isZero_tensorZero _)).eq_of_src _ _ + · exact (isZero_zero A).eq_of_tgt _ _ + · -- (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 _ _ + · show 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] + show Q.even ◁ η_ P.odd Q.odd ≫ + (α_ Q.even P.odd Q.odd).inv ≫ + biprod.inl ▷ Q.odd ≫ + ((0 : (Q.even ⊗ P.odd ⊞ Q.odd ⊗ P.even) ⟶ + (0 : A)) ▷ Q.odd) ≫ + biprod.inr = 0 + simp + · exact (isZero_tensorZero _).eq_of_src _ _ + · apply biprod.hom_ext' + · exact (isZero_tensorZero _).eq_of_src _ _ + · simp [assocOdd, rightUnitorCompOdd, leftUnitorComp] + show Q.odd ◁ η_ P.even Q.even ≫ + (α_ Q.odd P.even Q.even).inv ≫ + biprod.inr ▷ Q.even ≫ + ((0 : (Q.even ⊗ P.odd ⊞ Q.odd ⊗ P.even) ⟶ + (0 : A)) ▷ Q.even) ≫ + biprod.inr = 0 + simp + evaluation_coevaluation' := by + ext + · apply biprod.hom_ext' + · simp [assocEven, rightUnitorComp, leftUnitorComp] + show η_ P.odd Q.odd ▷ P.even ≫ + (α_ P.odd Q.odd P.even).hom ≫ + P.odd ◁ biprod.inr ≫ + (P.odd ◁ (0 : (Q.even ⊗ P.odd ⊞ Q.odd ⊗ P.even) ⟶ + (0 : A))) ≫ + biprod.inr = 0 + simp + · exact (isZero_zeroTensor _).eq_of_src _ _ + · apply biprod.hom_ext' + · simp [assocOdd, rightUnitorCompOdd, leftUnitorComp] + show η_ P.even Q.even ▷ P.odd ≫ + (α_ P.even Q.even P.odd).hom ≫ + P.even ◁ biprod.inl ≫ + (P.even ◁ (0 : (Q.even ⊗ P.odd ⊞ Q.odd ⊗ P.even) ⟶ + (0 : A))) ≫ + biprod.inl = 0 + simp + · 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..f16ccc8573 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DualityMate.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 +-/ + +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. +-/ + +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..2836bf29b7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/EvenEmbedMonoidal.lean @@ -0,0 +1,248 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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] + · exact (isZero_zero A).eq_of_tgt _ _ + μ_natural_right := by + intro X Y X' f + ext + · simp [evenEmbedTensorIso, isoBiprodZero] + · exact (isZero_zero A).eq_of_tgt _ _ + 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] + · exact (isZero_zero A).eq_of_tgt _ _ + left_unitality := by + intro X + ext + · apply biprod.hom_ext' <;> + simp [evenEmbedTensorIso, isoBiprodZero, leftUnitorComp] + rfl + · exact (isZero_zero A).eq_of_tgt _ _ + right_unitality := by + intro X + ext + · apply biprod.hom_ext' <;> + simp [evenEmbedTensorIso, isoBiprodZero, rightUnitorComp] + rfl + · exact (isZero_zero A).eq_of_tgt _ _ + +/-- 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 + haveI : 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 + haveI : 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..b9fd8fa509 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ExactFromShort.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 +-/ + +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. + +-/ + +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 0 3).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 0 3).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 0 2).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..ac690cbe63 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FactorialBeats.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 +-/ + +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). +-/ + +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..d14f1c6f7e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreAdditive.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 +-/ + +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. +-/ + +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 => ?_ + · show m ≫ (R ◁ (f + g)) = m ≫ (R ◁ f) + m ≫ (R ◁ g) + rw [MonoidalPreadditive.whiskerLeft_add] + exact Preadditive.comp_add _ _ _ _ _ _ + · show 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..5d116f4c8c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreBridge.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive +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. +-/ + +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..835c7edaab --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreEps.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat +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. +-/ + +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..6eb7b53404 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreExact.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 +-/ + +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. +-/ + +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 + haveI : 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 => ?_ <;> + · show m ≫ Mod.Hom.hom f + m ≫ Mod.Hom.hom g = + m ≫ Mod.Hom.hom h + rw [← 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 + show (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 + show (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 + show (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..393995fd72 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFaithful.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive +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. +-/ + +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 + show (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) = _ + simp only [Category.assoc] + refine Eq.trans (Finset.sum_congr rfl fun i _ => h i) ?_ + rw [← 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 + show ((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 + show ((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 + haveI := hη + haveI : 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 + haveI : 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..3bba68b32f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFunctor.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 +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. +-/ + +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 => ?_ <;> + · show m ≫ (freeModMap A (𝟙 X)).hom = m + rw [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 => ?_ <;> + · show m ≫ (freeModMap A (f ≫ g)).hom = + (m ≫ (freeModMap A f).hom) ≫ (freeModMap A g).hom + rw [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..fa285c02b7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreLinear.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 +-/ + +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. +-/ + +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 => ?_ + · show m ≫ (R ◁ (c • f)) = c • (m ≫ (R ◁ f)) + rw [MonoidalLinear.whiskerLeft_smul] + exact CategoryTheory.Linear.comp_smul _ _ _ m c (R ◁ f) + · show 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..45e068e123 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMix.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreEps +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. +-/ + +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..935c98f2c3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMonoidal.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMuNat +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreEps +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffleCoh +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. +-/ + +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 -/ + +/-- **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 + 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, + 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, fibreMu_evenMap_tmulEE, + fibreMu_evenMap_tmulOO, fibreMu_oddMap_tmulEO, + fibreMu_oddMap_tmulOE, gammaFunMap_freeModMap_evenMap, + gammaFunMap_freeModMap_oddMap] + · refine freeModShuffle_assoc_at' R _ _ _ _ ?_ m n p + monoidal + · 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] + · 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 + · 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] + · refine freeModShuffle_assoc_at' R _ _ _ _ ?_ m n p + monoidal + · 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] + · refine freeModShuffle_assoc_at' R _ _ _ _ ?_ m n p + monoidal + · refine freeModShuffle_assoc_at' R _ _ _ _ ?_ m n p + monoidal + +/-! ## 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 => ?_) + · rw [leftUnitorHom_evenMap_tmulEE, comp_evenMap_apply, + comp_evenMap_apply, tensorHom_evenMap_tmulEE, + fibreMu_evenMap_tmulEE, gammaFunMap_freeModMap_evenMap] + exact (freeModShuffle_unit_left_at' R (λ_ (𝟙_ D)).inv x m).symm + · rw [leftUnitorHom_evenMap_tmulOO, comp_evenMap_apply, + comp_evenMap_apply, tensorHom_evenMap_tmulOO, + fibreMu_evenMap_tmulOO, gammaFunMap_freeModMap_evenMap] + exact (freeModShuffle_unit_left_at' R L.sq.inv u m).symm + · rw [leftUnitorHom_oddMap_tmulEO, comp_oddMap_apply, + comp_oddMap_apply, tensorHom_oddMap_tmulEO, + fibreMu_oddMap_tmulEO, gammaFunMap_freeModMap_oddMap] + exact (freeModShuffle_unit_left_at' R (λ_ L.obj).inv x m).symm + · rw [leftUnitorHom_oddMap_tmulOE, comp_oddMap_apply, + comp_oddMap_apply, tensorHom_oddMap_tmulOE, + fibreMu_oddMap_tmulOE, gammaFunMap_freeModMap_oddMap] + 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 => ?_) + · rw [rightUnitorHom_evenMap_tmulEE, comp_evenMap_apply, + comp_evenMap_apply, tensorHom_evenMap_tmulEE, + fibreMu_evenMap_tmulEE, gammaFunMap_freeModMap_evenMap] + exact (freeModShuffle_unit_right_ee R V m x).symm + · rw [rightUnitorHom_evenMap_tmulOO, comp_evenMap_apply, + comp_evenMap_apply, tensorHom_evenMap_tmulOO, + fibreMu_evenMap_tmulOO, gammaFunMap_freeModMap_evenMap] + exact (freeModShuffle_unit_right_oo L R V m u).symm + · rw [rightUnitorHom_oddMap_tmulEO, comp_oddMap_apply, + comp_oddMap_apply, tensorHom_oddMap_tmulEO, + fibreMu_oddMap_tmulEO, gammaFunMap_freeModMap_oddMap] + exact (freeModShuffle_unit_right_eo L R V m u).symm + · rw [rightUnitorHom_oddMap_tmulOE, comp_oddMap_apply, + comp_oddMap_apply, tensorHom_oddMap_tmulOE, + fibreMu_oddMap_tmulOE, gammaFunMap_freeModMap_oddMap] + 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 => ?_) + · rw [comp_evenMap_apply, braidingHom_evenMap_tmulEE, + fibreMu_evenMap_tmulEE, comp_evenMap_apply, + fibreMu_evenMap_tmulEE, gammaFunMap_freeModMap_evenMap] + exact (freeModShuffle_braiding_ee R V W m n).symm + · rw [comp_evenMap_apply, braidingHom_evenMap_tmulOO, map_neg, + fibreMu_evenMap_tmulOO, comp_evenMap_apply, + fibreMu_evenMap_tmulOO, gammaFunMap_freeModMap_evenMap] + exact (freeModShuffle_braiding_oo L R V W m n).symm + · rw [comp_oddMap_apply, braidingHom_oddMap_tmulEO, + fibreMu_oddMap_tmulOE, comp_oddMap_apply, + fibreMu_oddMap_tmulEO, gammaFunMap_freeModMap_oddMap] + exact (freeModShuffle_braiding_eo L R V W m n).symm + · rw [comp_oddMap_apply, braidingHom_oddMap_tmulOE, + fibreMu_oddMap_tmulEO, comp_oddMap_apply, + fibreMu_oddMap_tmulOE, gammaFunMap_freeModMap_oddMap] + 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..9454b707c4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMu.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat +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. +-/ + +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 + rw [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 + rw [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 + rw [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 + rw [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 + haveI := h + haveI : 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..9a20b5bc52 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMuNat.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 +-/ + +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. +-/ + +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 + show ((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 + rw [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 + rw [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 + rw [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 + rw [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..5a3971ab9b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverComplex.lean @@ -0,0 +1,338 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescentClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMix +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfLinear +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointBaseChange +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. +-/ + +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 + letI := linearOfScalarUnit ψ + letI := monoidalLinearOfScalarUnitBraided ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := 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)) + letI := hmon + letI := 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 + haveI := finiteDimensional_fibre_tensor_point_even L 𝔸 P e + haveI := 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 + letI := linearOfScalarUnit ψ + letI := monoidalLinearOfScalarUnitBraided ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + obtain ⟨𝔸, hmon, hcomm, hne, hmixed, hsec, ⟨P⟩⟩ := + exists_superPoint_of_countable_family ψ L Xf V W g hlen hmix hsplit + letI := hmon + letI := 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 + letI := linearOfScalarUnit ψ + letI := monoidalLinearOfScalarUnitBraided ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := 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..bb95550255 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverSplitting.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplittingAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreExact +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFaithful +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreBridge +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`. +-/ + +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 + haveI : (indOf (C := C)).Additive := indOf_additive + haveI : ((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 + haveI : (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 + haveI : (indOf (C := C)).Additive := indOf_additive + haveI : ((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 + haveI : (indOf (C := C)).Additive := indOf_additive + haveI : ((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..5820f86589 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreRestrict.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 +-/ + +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. +-/ + +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_ε]; infer_instance + 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..e2f74f0251 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreStrong.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMonoidal +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. +-/ + +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_ε] + infer_instance + 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..41c9115ffe --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FiltNil.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 +-/ + +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`. +-/ + +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 [dif_pos (Nat.zero_le N)] + exact htop + · rw [dif_pos (le_refl N)] + exact hbot + · intro k hk + have h1 : k ≤ N := Nat.le_of_lt hk + have h2 : k + 1 ≤ N := hk + rw [dif_pos h2, dif_pos 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..1f7dce9924 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FlatLimit.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 +-/ + +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. +-/ + +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*} [Fintype κ] (x : κ → R) : + ∃ i, ∃ y : κ → F i, ∀ k, P.toColim i (y k) = x k := by + classical + 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*} [Fintype κ] {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 + 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..cbcb30aaed --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeCollapseAlg.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 +-/ + +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. +-/ + +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 + | hM σ => + rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n))) σ = + MonoidAlgebra.single σ (1 : ℂ) from rfl, permAlg_single, + permAlg_single] + exact freeCollapse_permMor A V n σ + | hadd z₁ z₂ h₁ h₂ => + rw [map_add, map_add] + exact add_pass_free h₁ h₂ + | hsmul 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..a543bd605a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeMixRetract.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 +-/ + +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. +-/ + +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 ι] + [DecidableEq ι] (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..3eb9145170 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModAdjoint.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeMixRetract +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. +-/ + +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 + show A ◁ (u ≫ g) ≫ actLeft A M.X = + A ◁ u ≫ A ◁ g ≫ actLeft A M.X + rw [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..6751bc94e8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModBiprod.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 +-/ + +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. +-/ + +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..27d218724d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModFunctor.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFunctor +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). +-/ + +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..0bafde5c16 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffle.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +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. +-/ + +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 + show ((α_ B B (𝟙_ D)).inv ≫ μ[B] ▷ (𝟙_ D)) ≫ + (ρ_ B).hom = (B ◁ (ρ_ B).hom) ≫ μ[B] + exact freeModUnit_linear B) + inv := Mod.Hom.mk' (ρ_ B).inv (by + show μ[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 + show ((α_ 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 + show 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 + show (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 + show (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..2c8a219c4a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffleCoh.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor +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. +-/ + +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..5674fbaef5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModTensor.lean @@ -0,0 +1,383 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle +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. +-/ + +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 + show 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 + show ((α_ 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 + rw [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..f6ab01d44a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormalise.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseStep +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseBase +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowStage +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowDesc +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. +-/ + +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 => + rw [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 + rw [← 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..bccb866993 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseBase.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 +-/ + +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. +-/ + +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..134a03d4cb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseStep.lean @@ -0,0 +1,208 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowInsert +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. +-/ + +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] + show (((β_ 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] + [IsCommMonObj 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..0fd79ce6de --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePow.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowCast +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PlainShuffle +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. +-/ + +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 + simp only [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 + show (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 => + show 𝟙 _ ≫ _ = _ + 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 ?_ + show (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..73f1d73bd2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowDesc.lean @@ -0,0 +1,399 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffleCoh +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. +-/ + +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 + show (ρ_ (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] + show ((α_ (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] [IsCommMonObj 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] + show (((β_ (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] + show ((α_ (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 + show (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)) + rw [hglue, MonoidalCategory.tensorHom_def] + simp only [Category.assoc] + rw [← MonoidalCategory.comp_whiskerRight_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc] + simp only [Category.assoc] + rw [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, Category.id_comp, modPowLegM, modPowLegN, + Category.assoc] + show ((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..0e0d981859 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowInsert.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 +-/ + +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. +-/ + +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] [IsCommMonObj A] (n : ℕ) : + unitWord A n ≫ muFold A n = η[A] := by + induction n with + | zero => exact Category.id_comp _ + | succ n ih => + show ((ρ_ (𝟙_ 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 => + show 𝟙 (𝟙_ D) ≫ (λ_ (𝟙_ D)).inv = + (λ_ (𝟙_ D)).inv ≫ (𝟙 (𝟙_ D) ▷ 𝟙_ D) + rw [Category.id_comp, MonoidalCategory.id_whiskerRight, + Category.comp_id] + | succ n ih => + show (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] + show ((α_ 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..751386e8ef --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSlide.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 +-/ + +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. +-/ + +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 + letI := freeModObj A V + show 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 + letI := 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 + letI := 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 + letI := 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 + simp only [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 _ _)) + rw [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..125a15e895 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSummand.lean @@ -0,0 +1,864 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModAdjoint +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. +-/ + +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 => ?_ + show ((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 _) + show 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} [Fintype J] [Fintype K] + [Fintype 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 + 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} [Fintype J] [Fintype 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 + 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} [Fintype J] [DecidableEq J] + {f : J → D} (j : J) : + biproduct.components (𝟙 (⨁ f)) j j = 𝟙 (f j) := by + 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} [Fintype J] [DecidableEq J] + {f : J → D} {j k : J} (h : j ≠ k) : + biproduct.components (𝟙 (⨁ f)) j k = 0 := by + 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 ?_ + show 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} [Fintype J] + [DecidableEq J] (V : D) (g : J → D) + (h : ∀ k, UnitBij R V (g k)) : UnitBij R V (⨁ g) := by + 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 ?_ + show (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, ?_⟩ + show (∑ 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} [Fintype J] + [DecidableEq J] (f : J → D) (W : D) + (h : ∀ j, UnitBij R (f j) W) : UnitBij R (⨁ f) W := by + 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 ?_ + show (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, ?_⟩ + show (∑ 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 ?_⟩ + show 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 ?_⟩ + show 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), ?_⟩ + show (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, ?_⟩ + show (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, ?_⟩ + show (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, ?_⟩ + show (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 + show 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 + show 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 + show (λ_ 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 ?_ + show 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.zero_comp, Limits.comp_zero, + Finset.sum_const_zero, add_zero, zero_add, Matrix.mul_apply] + · exact sum_smul_id _ _ + · 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 + · show (1 : Matrix (Fin p) (Fin p) ℂ) i i • 𝟙 (𝟙_ D) = 𝟙 (𝟙_ D) + rw [Matrix.one_apply_eq, one_smul] + · show (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]) + show (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]) + show (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 => ?_⟩ + rw [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..a3f76387a0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeTwistPi.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair +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. +-/ + +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 _ _ + show 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] + show ((β_ 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 + rw [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..7d1cdb101f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaAlgebra.lean @@ -0,0 +1,306 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing +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`. +-/ + +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..6f43a986a2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaBiprod.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModIso +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. +-/ + +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..64ad137a1c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaComplex.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleScalars +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. +-/ + +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 𝔸] [MonObj 𝔹] + [IsCommMonObj 𝔹] (π : 𝔸 ⟶ 𝔹) [Epi π] + (hcp : CountablyPresented 𝔸) (hne : η[𝔹] ≠ 0) + (hsimple : ∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) + (g : 𝟙_ (Ind C) ⟶ 𝔹) : ∃ c : ℂ, g = c • η[𝔹] := by + letI : 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..494188e229 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaCountable.lean @@ -0,0 +1,626 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableNullstellensatz +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.HomFinite +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEvenRing +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`). +-/ + +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 + haveI := 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 + haveI : 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 + letI := hcat + letI := hfil + letI := 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 + letI : DecidableRel (WellOrderingRel (α := J)) := + Classical.decRel _ + letI : 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 + letI : ∀ i : J ⊕ K, MonObj (Sum.elim Am Bs i) := fun i => + match i with + | Sum.inl j => Amon j + | Sum.inr k => Bmon k + letI : ∀ 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) + haveI : 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) + haveI : 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 + haveI := 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 + haveI : 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..ee73747185 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModule.lean @@ -0,0 +1,355 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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. +@[nolint checkUnivs] +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..7af952e458 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModuleFunctor.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 +-/ + +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. +-/ + +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 => ?_ <;> + · show m ≫ Mod.Hom.hom (𝟙 M) = m + rw [Mod.id_hom', Category.comp_id] + map_comp {M N P} f g := by + refine SuperCommAlgebra.Mod.Hom.ext ?_ ?_ <;> + refine LinearMap.ext fun m => ?_ <;> + · show m ≫ Mod.Hom.hom (f ≫ g) = (m ≫ f.hom) ≫ g.hom + rw [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..81dd0eeea9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPair.lean @@ -0,0 +1,1045 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom +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`. +-/ + +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 + show 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)) + rw [gammaPairEven_tmulEE, gammaPairEven_tmulEE] + exact (gpair_act_eee M N x m n).symm + · intro m n + show 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)) + rw [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 + show 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)) + rw [gammaPairOdd_tmulEO, gammaPairOdd_tmulEO] + exact (gpair_act_eeo L M N x m n).symm + · intro m n + show 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)) + rw [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 + show 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)) + rw [gammaPairOdd_tmulOE, gammaPairEven_tmulEE] + exact (gpair_act_oee L M N u m n).symm + · intro m n + show 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)) + rw [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 + show 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)) + rw [gammaPairEven_tmulOO, gammaPairOdd_tmulEO] + exact (gpair_act_oeo L M N u m n).symm + · intro m n + show 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)) + rw [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..71b2fb299d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairAdd.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor +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. +-/ + +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] + show ∑ i ∈ s, m ≫ (g i).hom = m + rw [← Preadditive.comp_sum, h, Category.comp_id] + · rw [SuperCommAlgebra.Mod.sum_oddMap_apply] + show ∑ i ∈ s, m ≫ (g i).hom = m + rw [← 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..237f578a37 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeFree.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeMix +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetractRight +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. +-/ + +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..7cda1ac41f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeMix.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetract +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairUnit +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. +-/ + +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..b422794a78 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairNat.lean @@ -0,0 +1,357 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair +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. +-/ + +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 + show ((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, gammaPairEven_tmulEE] + exact gpairLin_naturality R _ f g m n + · simp only [comp_evenMap_apply, gammaPairComparison_evenMap, + tensorHom_evenMap_tmulOO, gammaPairEven_tmulOO] + exact gpairLin_naturality R _ f g m n + · simp only [comp_oddMap_apply, gammaPairComparison_oddMap, + tensorHom_oddMap_tmulEO, gammaPairOdd_tmulEO] + exact gpairLin_naturality R _ f g m n + · simp only [comp_oddMap_apply, gammaPairComparison_oddMap, + tensorHom_oddMap_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 + haveI := h + haveI : IsIso (gammaFunMap L R (modTensorMapMod R e.hom e'.hom)) := + ((gammaModuleFunctor L R).mapIso + (modTensorMapModIso R e e')).isIso_hom + haveI : 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..bbd0b3f0b3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetract.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat +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. +-/ + +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 + rw [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 + haveI := 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..55cd0a0dc0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetractRight.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetract +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. +-/ + +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 + rw [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 + haveI := 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..ca896bf616 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairUnit.lean @@ -0,0 +1,330 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract +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`. +-/ + +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 + rw [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 + rw [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 + rw [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 + rw [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 + rw [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 + rw [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 + rw [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 + rw [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 + rw [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 + rw [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] + infer_instance + +/-- 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] + infer_instance + +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..55d33bdf30 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaShift.lean @@ -0,0 +1,253 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoTwist +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModIso +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`. +-/ + +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..b250762b2e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaTwistLeft.lean @@ -0,0 +1,384 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaShift +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`. +-/ + +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 + letI := 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 + show (λ_ 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 + letI := 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 + show (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 + show 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 + show 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..0b66db7a13 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GeneratorAlgebra.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescentClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndLocallyMixed +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndUnitNonzero +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. +-/ + +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 + letI := linearOfScalarUnit ψ + letI := monoidalLinearOfScalarUnitBraided ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := 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..7978c5ca44 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GrowthDichotomy.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdempotentLength +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FactorialBeats +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BlockUnits +import LeanPool.RegtsSevenster.RS.Classical.Deligne.WhiskerFaithful +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple +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. +-/ + +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..bf69247b44 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HomFinite.lean @@ -0,0 +1,433 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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. -/ +private 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 + haveI : Simple (𝟙_ A) := simple_unit_of_hasScalarUnit hu + haveI : 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 + haveI := 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 + haveI := hs + intro N + induction N with + | zero => + intro Z h + rcases subsingleton_or_nontrivial (𝟙_ A ⟶ Z) with hss | hnt + · haveI := hss + exact ⟨inferInstance, by + rw [Module.finrank_zero_of_subsingleton]⟩ + · haveI := hnt + obtain ⟨φ, hφ⟩ := exists_ne (0 : 𝟙_ A ⟶ Z) + haveI : 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 + · haveI := hss + exact ⟨inferInstance, by + rw [Module.finrank_zero_of_subsingleton]; exact Nat.zero_le _⟩ + · haveI := hnt + obtain ⟨φ, hφ⟩ := exists_ne (0 : 𝟙_ A ⟶ Z) + haveI : Mono φ := mono_of_nonzero_from_simple hφ + obtain ⟨hfinQ, hrkQ⟩ := ih (cokernel φ) (lengthLE_cokernel φ hφ h) + haveI := 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⟩ + haveI hkfin : FiniteDimensional ℂ (LinearMap.ker L) := + Submodule.finiteDimensional_of_le hker + haveI hrfin : FiniteDimensional ℂ (LinearMap.range L) := + inferInstance + haveI 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 + haveI := 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..5e359d2212 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookMult.lean @@ -0,0 +1,220 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 [dif_pos 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..f5063a0c55 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookZero.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 +-/ + +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. +-/ + +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_upperTriangular (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, if_neg hnotlt, + if_neg 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 ?_ + show (j : ℕ) - ((j : ℕ) - (k : ℕ)) = (k : ℕ) + omega + · intro d hd + rw [Finset.mem_range] at hd + show (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, if_neg hnotlt, + if_pos 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] + show c i₀ = + if h : (i₀ : ℕ) < p + 1 then c ⟨(i₀ : ℕ), h⟩ else 0 + rw [dif_pos i₀.isLt] + _ = 0 := by rw [h0]; rfl + -- The extended vector annihilates the transformed matrix. + have hvm : Matrix.vecMul w M = 0 := by + funext j + show ∑ 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 + show 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 [dif_neg 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 [dif_pos 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, if_neg (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 [if_pos h] + have hlen : ν.rowLens.length ≤ 1 := by + rw [YoungDiagram.length_rowLens]; exact h + rw [diagramSchur, schurDet_eq_det_jtMatrix, + Matrix.det_of_upperTriangular + (by + intro i j hji + have hji' : (j : ℕ) < (i : ℕ) := hji + have hi := i.isLt + omega)] + refine Finset.prod_eq_one fun i _ => ?_ + show 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 [if_neg 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 [if_pos 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_lowerTriangular _ (by + intro i j hij + have hij' : (i : ℕ) < (j : ℕ) := hij + show 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 _ => ?_ + show 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 [if_neg 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..8d3b3be10b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean @@ -0,0 +1,711 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermNat +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. +-/ + +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] + show (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 + show (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 + rw [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 + | hM σ => + rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n))) σ = + MonoidAlgebra.single σ (1 : ℂ) from rfl, modPowAlg_single, + modPowAlg_single] + exact modPowMap_perm A f n σ + | hadd z₁ z₂ h₁ h₂ => + rw [map_add, map_add] + exact (intertwine_add h₁.symm h₂.symm).symm + | hsmul 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..3542c461d7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdempotentLength.lean @@ -0,0 +1,233 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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⟩ := + dif_pos 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..3ee227d5bc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ImageSubalgebra.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 +-/ + +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. +-/ + +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 + haveI : Epi (f ▷ X') := inferInstanceAs (Epi ((tensorRight X').map f)) + haveI : 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 + rw [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 + rw [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 + rw [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 + rw [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..281c7c39bb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndAllColim.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCoeq +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. +-/ + +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..8793489fc6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndBigTensorUnit.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensorUnit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndPointTensor +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. +-/ + +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..250c54f3ff --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCoeq.lean @@ -0,0 +1,913 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact +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. +-/ + +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 ⋙ (evaluation K 𝒟).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 ?_ + exact congrArg (fun t => t ≫ (colimit.ι G.flip a).app b) + (limitObjIsoLimitCompEvaluation_inv_π_app G b a) + exact hL.trans hR.symm + haveI : 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) + haveI : PreservesColimitsOfSize.{0, 0} (tensorLeft a) := + preservesSmallestColimits_of_preservesColimits _ + haveI : PreservesColimit (parallelPair P.φ P.ψ) + (Ind.lim P.I ⋙ tensorLeft (indOf.obj a)) := + preservesColimit_of_natIso _ (indLimCompTensorLeftIso a P.I).symm + haveI : 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) + haveI : PreservesLimitsOfSize.{0, 0} (tensorLeft a) := + preservesSmallestLimits_of_preservesLimits _ + haveI : PreservesLimit (parallelPair P.φ P.ψ) + (Ind.lim P.I ⋙ tensorLeft (indOf.obj a)) := + preservesLimit_of_natIso _ (indLimCompTensorLeftIso a P.I).symm + haveI : 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) + haveI : PreservesLimitsOfSize.{0, 0} (tensorRight a) := + preservesSmallestLimits_of_preservesLimits _ + haveI : PreservesLimit (parallelPair P.φ P.ψ) + (Ind.lim P.I ⋙ tensorRight (indOf.obj a)) := + preservesLimit_of_natIso _ (indLimCompTensorRightIso a P.I).symm + haveI : 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) + haveI : PreservesColimitsOfSize.{0, 0} (tensorRight a) := + preservesSmallestColimits_of_preservesColimits _ + haveI : PreservesColimit (parallelPair P.φ P.ψ) + (Ind.lim P.I ⋙ tensorRight (indOf.obj a)) := + preservesColimit_of_natIso _ (indLimCompTensorRightIso a P.I).symm + haveI : 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 + show 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 + show (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 + show 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] + show ((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] + show 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 + show 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] + show ((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] + show (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 + haveI : PreservesFilteredColimits (whiskerLeftPairFunctor f g) := + preservesFilteredColimits_whiskerLeftPairFunctor f g + haveI : PreservesColimitsOfSize.{v, v} + (colim : (WalkingParallelPair ⥤ Ind C) ⥤ Ind C) := + colimConstAdj.leftAdjoint_preservesColimits + haveI : PreservesFilteredColimits + (whiskerLeftPairFunctor f g ⋙ colim) := + ⟨fun _ _ _ => inferInstance⟩ + have h := isIso_app_of_isIso_indOf (whiskerLeftCoeqComparison f g) + (fun c => by + haveI := 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 + haveI : PreservesFilteredColimits (whiskerRightPairFunctor f g) := + preservesFilteredColimits_whiskerRightPairFunctor f g + haveI : PreservesColimitsOfSize.{v, v} + (colim : (WalkingParallelPair ⥤ Ind C) ⥤ Ind C) := + colimConstAdj.leftAdjoint_preservesColimits + haveI : PreservesFilteredColimits + (whiskerRightPairFunctor f g ⋙ colim) := + ⟨fun _ _ _ => inferInstance⟩ + have h := isIso_app_of_isIso_indOf (whiskerRightCoeqComparison f g) + (fun c => by + haveI := 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 + haveI := isIso_post_parallelPair_tensorLeft A + (K.map WalkingParallelPairHom.left) + (K.map WalkingParallelPairHom.right) + haveI : 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 + haveI := isIso_post_parallelPair_tensorRight A + (K.map WalkingParallelPairHom.left) + (K.map WalkingParallelPairHom.right) + haveI : 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 + haveI hlim : PreservesColimitsOfShape I + (lim : (WalkingParallelPair ⥤ (Cᵒᵖ ⥤ Type v)) ⥤ _) := + preservesColimitsOfShape_lim + haveI 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 + haveI : PreservesFilteredColimits (whiskerLeftPairFunctor f g) := + preservesFilteredColimits_whiskerLeftPairFunctor f g + haveI : PreservesFilteredColimits + (whiskerLeftPairFunctor f g ⋙ lim) := + ⟨fun I _ _ => by + haveI := preservesColimitsOfShape_parallelPairLim_ind (C := C) I + infer_instance⟩ + have h := isIso_app_of_isIso_indOf (whiskerLeftEqComparison f g) + (fun c => by + haveI := 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 + haveI : PreservesFilteredColimits (whiskerRightPairFunctor f g) := + preservesFilteredColimits_whiskerRightPairFunctor f g + haveI : PreservesFilteredColimits + (whiskerRightPairFunctor f g ⋙ lim) := + ⟨fun I _ _ => by + haveI := preservesColimitsOfShape_parallelPairLim_ind (C := C) I + infer_instance⟩ + have h := isIso_app_of_isIso_indOf (whiskerRightEqComparison f g) + (fun c => by + haveI := 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 + haveI := isIso_limitPost_parallelPair_tensorLeft A + (K.map WalkingParallelPairHom.left) + (K.map WalkingParallelPairHom.right) + haveI : 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 + haveI := isIso_limitPost_parallelPair_tensorRight A + (K.map WalkingParallelPairHom.left) + (K.map WalkingParallelPairHom.right) + haveI : 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..b89e088ca1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCompact.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 +-/ + +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`). +-/ + +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 + show (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 + -- The residue is the definitional identification of the two + -- `TypeCat` hom-coercion routes through `Functor.comp`. + rfl) + +/-- **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..aa14067e62 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndDayClosure.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 +-/ + +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`. +-/ + +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) + exact (isIndObject_colimit Q.I E hE).map + (IsColimit.coconePointUniqueUpToIso (colimit.isColimit E) hc₃).hom + +/-- 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..d3ca7c49f1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndImage.lean @@ -0,0 +1,269 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 _ _ _) + haveI : 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] + haveI := hmono + haveI : 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..3964500776 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplit + +/-! +# 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. +-/ + +namespace RS + +open Finset + +private theorem ma_add_apply {G : Type*} (f g : MonoidAlgebra ℂ G) + (x : G) : (f + g) x = f x + g x := + Finsupp.add_apply f g x + +private theorem ma_smul_apply {G : Type*} (r : ℂ) + (f : MonoidAlgebra ℂ G) (x : G) : (r • f) x = r * f x := + (Finsupp.smul_apply r f x).trans (smul_eq_mul _ _) + +/-- 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] [DecidableEq G] (x : MonoidAlgebra ℂ G) : + LinearMap.trace ℂ (MonoidAlgebra ℂ G) + (LinearMap.mulLeft ℂ x) = + (Fintype.card G : ℂ) * x 1 := by + classical + have hb : LinearMap.trace ℂ (G →₀ ℂ) + (LinearMap.mulLeft ℂ x) = + Matrix.trace (LinearMap.toMatrix Finsupp.basisSingleOne + Finsupp.basisSingleOne (LinearMap.mulLeft ℂ x)) := + LinearMap.trace_eq_matrix_trace ℂ _ _ + show LinearMap.trace ℂ (G →₀ ℂ) (LinearMap.mulLeft ℂ x) = _ + rw [hb, Matrix.trace] + have hdiag : ∀ g : G, + Matrix.diag (LinearMap.toMatrix Finsupp.basisSingleOne + Finsupp.basisSingleOne (LinearMap.mulLeft ℂ x)) g = + x 1 := by + intro g + rw [Matrix.diag_apply, LinearMap.toMatrix_apply] + simp only [Finsupp.coe_basisSingleOne, + Finsupp.basisSingleOne_repr, LinearEquiv.refl_apply] + exact (MonoidAlgebra.mul_single_apply x 1 g g).trans + (by rw [mul_inv_cancel, mul_one]) + rw [Finset.sum_congr rfl fun g _ => hdiag g, + Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + +/-- 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] + [Fintype G] [DecidableEq G] {x : MonoidAlgebra ℂ G} + (hidem : x * x = x) (h1 : x 1 = 0) : x = 0 := by + classical + 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 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 (g⁻¹ * k * g) = Shape.e P lam 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 + show (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 + conv_lhs => rw [← Finsupp.sum_single y] + conv_rhs => rw [← Finsupp.sum_single y] + show Shape.e P lam * (∑ g ∈ y.support, + Finsupp.single g (y g) : SymGroupAlgebra n) = + (∑ g ∈ y.support, + Finsupp.single g (y g) : SymGroupAlgebra n) * Shape.e P lam + rw [Finset.mul_sum, Finset.sum_mul] + exact Finset.sum_congr rfl fun g _ => hsingle g _ + intro g c + ext k + rw [MonoidAlgebra.mul_single_apply, + MonoidAlgebra.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 + | hM σ => + induction y using MonoidAlgebra.induction_on with + | hM τ => + have hL : MonoidAlgebra.mapDomainAlgHom ℂ ℂ + (blockEmbedFstHom a b) (MonoidAlgebra.single σ 1) = + MonoidAlgebra.single (blockEmbed σ 1) (1 : ℂ) := by + show 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 + show 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 + | hadd y y' hy hy' => + rw [map_add, mul_add, add_mul, hy, hy'] + | hsmul r y hy => + rw [map_smul, mul_smul_comm, smul_mul_assoc, hy] + | hadd x x' hx hx' => + rw [map_add, add_mul, mul_add, hx, hx'] + | hsmul 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 (blockEmbed σ τ) = x σ * y τ := by + classical + induction x using MonoidAlgebra.induction_on with + | hM σ₀ => + induction y using MonoidAlgebra.induction_on with + | hM τ₀ => + 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 [MonoidAlgebra.single_apply, hne, hσ] + · simp [MonoidAlgebra.single_apply, hne, hτ] + | hadd y y' hy hy' => + rw [blockAlgEmbed_add_snd, ma_add_apply, hy, hy', + ma_add_apply, mul_add] + | hsmul r y hy => + rw [blockAlgEmbed_smul_snd, ma_smul_apply, hy, + ma_smul_apply] + ring + | hadd x x' hx hx' => + rw [blockAlgEmbed_add_fst, ma_add_apply, hx, hx', + ma_add_apply, add_mul] + | hsmul 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 g = 0 := by + classical + induction x using MonoidAlgebra.induction_on with + | hM σ₀ => + induction y using MonoidAlgebra.induction_on with + | hM τ₀ => + simp only [MonoidAlgebra.of_apply] + rw [blockAlgEmbed_single] + have hne : blockEmbed σ₀ τ₀ ≠ g := fun he => h σ₀ τ₀ he.symm + simp [hne] + | hadd y y' hy hy' => + rw [blockAlgEmbed_add_snd, ma_add_apply, hy, hy', add_zero] + | hsmul r y hy => + rw [blockAlgEmbed_smul_snd, ma_smul_apply, hy, mul_zero] + | hadd x x' hx hx' => + rw [blockAlgEmbed_add_fst, ma_add_apply, hx, hx', add_zero] + | hsmul 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] + [DecidableEq G] (x y : MonoidAlgebra ℂ G) : + (x * y) 1 = ∑ g : G, x g * y g⁻¹ := by + classical + conv_lhs => rw [← Finsupp.sum_single x] + show ((∑ g ∈ x.support, MonoidAlgebra.single g (x g)) * y) 1 = _ + rw [Finset.sum_mul] + have happ : ((∑ g ∈ x.support, + MonoidAlgebra.single g (x g) * y)) 1 = + ∑ g ∈ x.support, + (MonoidAlgebra.single g (x g) * y) 1 := + Finsupp.finsetSum_apply x.support + (fun g => MonoidAlgebra.single g (x g) * y) 1 + rw [happ] + rw [Finset.sum_congr rfl fun g _ => + (MonoidAlgebra.single_mul_apply y (x g) g 1).trans + (by rw [mul_one])] + 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 ν)) 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 g * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν) g⁻¹) = + ∑ g : Equiv.Perm (Fin (a + b)), + Shape.e P lam g⁻¹ * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν) g := + Fintype.sum_equiv (Equiv.inv _) _ _ fun g => by + show Shape.e P lam g * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν) g⁻¹ = + Shape.e P lam g⁻¹⁻¹ * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν) 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 g⁻¹ * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν) 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 (blockEmbed σ τ)⁻¹ * + blockAlgEmbed (Shape.e P μ) (Shape.e P ν) + (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 ((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 μ) σ = + ((P.dim μ.val : ℂ) / ((a.factorial : ℂ))) * + jtChar μ.val (permCast μ.prop.symm σ) from h2, + show (Shape.e P ν) τ = + ((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..aea8c95d9a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndLocallyMixed.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29Close +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. +-/ + +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 + letI := linearOfScalarUnit ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := 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..0b37e73110 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndMonoidal.lean @@ -0,0 +1,130 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show (β_ (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..44755ec043 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfLinear.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaCountable +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. +-/ + +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 + letI := linearOfScalarUnit ψ + letI := 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 + letI := linearOfScalarUnit ψ + letI := 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 + letI := linearOfScalarUnit ψ + letI := 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..bb49661752 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfMonoidal.lean @@ -0,0 +1,393 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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 + rw [(dayCoyonedaCorepresentableBy a (𝟙_ D)).homEquiv_comp, + dayCoyonedaCorepresentableBy_homEquiv_iso, dayEvaluation_map_apply, + dayCoyonedaCorepresentableBy_homEquiv_apply, comp_natTrans, + NatTrans.comp_app, CategoryTheory.comp_apply, + 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..04fbfec5f3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndPointTensor.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointTensor +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`. +-/ + +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..3503f17acc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchur.lean @@ -0,0 +1,992 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact +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. +-/ + +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] + dsimp [coyonedaDayCorepresentableBy] + rw [coyonedaEquiv_apply] + 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 + simp only [← Category.assoc] + rw [(dayCoyonedaCorepresentableBy₂ a b c).homEquiv_comp, + (dayCoyonedaCorepresentableBy₂ a b c).homEquiv_comp, + (dayCoyonedaCorepresentableBy₂ a b c).homEquiv_comp, + (dayCoyonedaCorepresentableBy₂ a b c).homEquiv_comp, + dayCoyonedaCorepresentableBy₂_homEquiv_apply, + dayCoyonedaCorepresentableBy₂_homEquiv_apply, + dayEvaluation_map_apply, dayEvaluation_map_apply, + dayEvaluation_map_apply, dayEvaluation_map_apply, + 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] + show (α_ 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 + rw [(dayCoyonedaCorepresentableBy a b).homEquiv_comp, + (dayCoyonedaCorepresentableBy a b).homEquiv_comp, + dayCoyonedaCorepresentableBy_homEquiv_iso, + dayEvaluation_map_apply, dayEvaluation_map_apply, + dayCoyonedaCorepresentableBy_homEquiv_apply] + 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] + show (𝟙 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 + show ((α_ (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 + show (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 σ + show 𝟙 _ ≫ _ = _ ≫ 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 + haveI : HasFiniteBiproducts C := + HasFiniteBiproducts.of_hasFiniteCoproducts + haveI : 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..7af90bd1a8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean @@ -0,0 +1,331 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + letI := linearOfScalarUnit ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + haveI := indOf_additive (C := C) + induction x using MonoidAlgebra.induction_on with + | hM σ => + rw [MonoidAlgebra.of_apply, permAlg_single, permAlg_single] + exact indOfPowIso_permMor X n σ + | hadd 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) + | hsmul 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 + letI := linearOfScalarUnit ψ + letI := 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 + show 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] + rfl + +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..2657f4ad36 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSimple.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur +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. +-/ + +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 + haveI := indOf_additive (C := C) + constructor + intro U m hm + haveI := 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 + haveI := 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 + haveI : Epi (Ind.yoneda.fullyFaithful.preimage (g ≫ m)) := + epi_of_nonzero_to_simple hfne + haveI : Epi (g ≫ m) := by + rw [← hmap] + infer_instance + haveI : 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..f5b9baac9f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplit.lean @@ -0,0 +1,565 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CycleSplit +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. +-/ + +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 [if_pos hp, if_pos hp, colourChar_conj] + · rw [if_neg hp, if_neg 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 + haveI : 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, 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..710baaf039 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplitSection.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchurKilled +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. +-/ + +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 + haveI := indOf_additive (C := C) + letI i3 : HasRightDual ((T.map (indOf : C ⥤ Ind C)).X₃) := + hasRightDualIndOf T.X₃ + letI i3d : HasRightDual (((T.map (indOf : C ⥤ Ind C)).X₃)ᘁ) := + hasRightDualIndOf ((T.X₃)ᘁ) + letI 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..29da7d96bc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean @@ -0,0 +1,1407 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 ?_ + rw [coyonedaEquiv_apply, coyonedaEquiv_apply] + show 𝟙 (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 => ?_ + show 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 => ?_ + show (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 + show 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 + show 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 + show 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 + show 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 + show 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 + show 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 + show 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 => ?_)⟩ + show 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 => ?_)⟩ + show 𝟙 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) + haveI : 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 + +-- Raised budget: 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 + haveI : HasFiniteBiproducts C := + HasFiniteBiproducts.of_hasFiniteCoproducts + haveI : HasBinaryBiproducts C := + hasBinaryBiproducts_of_finite_biproducts C + haveI : PreservesBiproductsOfShape WalkingPair (tensorLeft a) := + PreservesFiniteBiproducts.preserves + haveI := preservesBinaryBiproducts_of_preservesBiproducts + (tensorLeft a) + haveI := 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))) + +-- Raised budget: 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 + haveI : HasFiniteBiproducts C := + HasFiniteBiproducts.of_hasFiniteCoproducts + haveI : HasBinaryBiproducts C := + hasBinaryBiproducts_of_finite_biproducts C + haveI : PreservesBiproductsOfShape WalkingPair (tensorRight a) := + PreservesFiniteBiproducts.preserves + haveI := preservesBinaryBiproducts_of_preservesBiproducts + (tensorRight a) + haveI := 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 + haveI 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 _ _⟩ + haveI hR : PreservesFilteredColimits + (coprodPairFunctor ((Functor.const (Ind C)).obj (indOf.obj x)) + (𝟭 (Ind C)) ⋙ tensorLeft (indOf.obj a)) := + ⟨fun I _ _ => by + haveI := IsFiltered.isConnected (C := I) + haveI := preservesColimitsOfShape_const_of_isConnected + (𝒜 := Ind C) (J := I) (indOf.obj x) + haveI := 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 + show 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 + haveI 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 _ _⟩ + haveI hR : PreservesFilteredColimits + (coprodPairFunctor ((Functor.const (Ind C)).obj (indOf.obj x)) + (𝟭 (Ind C)) ⋙ tensorRight (indOf.obj a)) := + ⟨fun I _ _ => by + haveI := IsFiltered.isConnected (C := I) + haveI := preservesColimitsOfShape_const_of_isConnected + (𝒜 := Ind C) (J := I) (indOf.obj x) + haveI := 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 + show 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 + haveI 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 _ _⟩ + haveI hR : PreservesFilteredColimits + (coprodPairFunctor (𝟭 (Ind C)) + ((Functor.const (Ind C)).obj Y) ⋙ + tensorLeft (indOf.obj a)) := + ⟨fun I _ _ => by + haveI := IsFiltered.isConnected (C := I) + haveI := preservesColimitsOfShape_const_of_isConnected + (𝒜 := Ind C) (J := I) Y + haveI := 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 + show 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 + haveI 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 _ _⟩ + haveI hR : PreservesFilteredColimits + (coprodPairFunctor (𝟭 (Ind C)) + ((Functor.const (Ind C)).obj Y) ⋙ + tensorRight (indOf.obj a)) := + ⟨fun I _ _ => by + haveI := IsFiltered.isConnected (C := I) + haveI := preservesColimitsOfShape_const_of_isConnected + (𝒜 := Ind C) (J := I) Y + haveI := 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 + show 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 + haveI 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 + show 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 + haveI 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 + show 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 _ _ + +-- Raised budget: 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 + haveI : 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₃) + +-- Raised budget: 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 + haveI : 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 + haveI := isIso_coprodComparison_tensorLeft A + (K.obj ⟨WalkingPair.left⟩) (K.obj ⟨WalkingPair.right⟩) + haveI := 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 + haveI := isIso_coprodComparison_tensorRight A + (K.obj ⟨WalkingPair.left⟩) (K.obj ⟨WalkingPair.right⟩) + haveI := 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 + haveI : HasBinaryBiproducts (Ind C) := + hasBinaryBiproducts_of_finite_biproducts (Ind C) + haveI := preservesZeroMorphisms_tensorLeft_ind A + haveI := preservesBinaryCoproducts_tensorLeft_ind A + haveI := 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 + haveI : HasBinaryBiproducts (Ind C) := + hasBinaryBiproducts_of_finite_biproducts (Ind C) + haveI := preservesZeroMorphisms_tensorRight_ind A + haveI := preservesBinaryCoproducts_tensorRight_ind A + haveI := 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..c316db2d3b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndUnitNonzero.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur +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. +-/ + +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..cfebc6ca99 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitDatum.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitBase +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. +-/ + +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) + show (λ_ 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 _] + rw [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) + show (ρ_ 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 _] + rw [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..f5d8bbfcfb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitState.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitDatum +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. +-/ + +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..932f0a4652 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainStage2 +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. +-/ + +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 + have hTpin : (MonoidalCategory.whiskerLeft A + (Y₁ := 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₂)).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₂) + rw [MonoidalCategory.whiskerLeft_comp, Category.assoc, hTpin] + simp only [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 + rw [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 => rw [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] + 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) ?_ + 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 + show (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 + show (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 + show (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..778ca0e1a3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KernelPow.lean @@ -0,0 +1,1007 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show 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 _ + show ((ρ_ (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 ?_ + rw [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 => + show 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 => + show 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)⟩ + haveI := 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 + haveI : 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 + haveI : 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 + haveI : 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 + haveI : 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 + haveI : 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 + haveI : 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 + haveI : 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 => + haveI : 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..278fa2d2fa --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemma.lean @@ -0,0 +1,186 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModContractL +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. +-/ + +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..56446d5d1d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaClose.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaData +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitMonHom +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitPairDef +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBNonzero +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. +-/ + +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 + letI := 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..9c46c3d075 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaData.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 +-/ + +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`. +-/ + +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..df3c919465 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KillerNonempty.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos +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. +-/ + +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..5f7dde2a14 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean @@ -0,0 +1,415 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +open Finset + +private theorem ma_add_apply {G : Type*} (f g : MonoidAlgebra ℂ G) + (x : G) : (f + g) x = f x + g x := + Finsupp.add_apply f g x + +private theorem ma_smul_apply {G : Type*} (r : ℂ) + (f : MonoidAlgebra ℂ G) (x : G) : (r • f) x = r * f x := + (Finsupp.smul_apply r f x).trans (smul_eq_mul _ _) + +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 + show 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 + show 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 + | hM σ => + induction y using MonoidAlgebra.induction_on with + | hM τ => + have hL : MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) + (MonoidAlgebra.single σ 1) = + MonoidAlgebra.single + ((σ, 1) : Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) + (1 : ℂ) := by + show 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 + show 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 + | hadd y y' hy hy' => + rw [map_add, mul_add, add_mul, hy, hy'] + | hsmul r y hy => + rw [map_smul, mul_smul_comm, smul_mul_assoc, hy] + | hadd x x' hx hx' => + rw [map_add, add_mul, mul_add, hx, hx'] + | hsmul 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 (σ, τ) = x σ * y τ := by + classical + induction x using MonoidAlgebra.induction_on with + | hM σ₀ => + induction y using MonoidAlgebra.induction_on with + | hM τ₀ => + 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 [MonoidAlgebra.single_apply, hne, hσ] + · simp [MonoidAlgebra.single_apply, hne, hτ] + | hadd y y' hy hy' => + rw [extProd_add_snd, ma_add_apply, hy, hy', ma_add_apply, + mul_add] + | hsmul r y hy => + rw [extProd_smul_snd, ma_smul_apply, hy, ma_smul_apply] + ring + | hadd x x' hx hx' => + rw [extProd_add_fst, ma_add_apply, hx, hx', ma_add_apply, + add_mul] + | hsmul 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 ν) (g⁻¹ * k * g) = + extProd (Shape.e P μ) (Shape.e P ν) k := by + show extProd (Shape.e P μ) (Shape.e P ν) + (g.1⁻¹ * k.1 * g.1, g.2⁻¹ * k.2 * g.2) = + extProd (Shape.e P μ) (Shape.e P ν) (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 + conv_lhs => rw [← Finsupp.sum_single z] + conv_rhs => rw [← Finsupp.sum_single z] + show extProd (Shape.e P μ) (Shape.e P ν) * + (∑ g ∈ z.support, Finsupp.single g (z g) : + MonoidAlgebra ℂ + (Equiv.Perm (Fin n) × Equiv.Perm (Fin n))) = + (∑ g ∈ z.support, Finsupp.single g (z g) : + MonoidAlgebra ℂ + (Equiv.Perm (Fin n) × Equiv.Perm (Fin n))) * + extProd (Shape.e P μ) (Shape.e P ν) + rw [Finset.mul_sum, Finset.sum_mul] + exact Finset.sum_congr rfl fun g _ => hsingle g _ + intro g c + ext k + rw [MonoidAlgebra.mul_single_apply, + MonoidAlgebra.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 (σ, σ) = x σ := by + show Finsupp.mapDomain (diagHom n) x (σ, σ) = x σ + exact Finsupp.mapDomain_apply (diagHom_injective n) x σ + +/-- 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 p = 0 := by + show Finsupp.mapDomain (diagHom n) x p = 0 + refine Finsupp.mapDomain_notin_range x 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)) (1, 1) = + (P.dim μ.val : ℂ) * (P.dim ν.val : ℂ) * + (P.dim lam.val : ℂ) / + ((n.factorial : ℂ) * (n.factorial : ℂ)) * + kronMult lam μ ν := by + classical + show (extProd (Shape.e P μ) (Shape.e P ν) * + diagEmbed (Shape.e P lam)) 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 ν) p * + diagEmbed (Shape.e P lam) 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 ν) (σ, σ) * + diagEmbed (Shape.e P lam) ((σ, σ)⁻¹) = + ((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) ((σ, σ)⁻¹) = + Shape.e P lam σ⁻¹ := + 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 σ⁻¹ = + ((P.dim lam.val : ℂ) / (n.factorial : ℂ)) * + jtChar lam.val (permCast lam.prop.symm σ) from hc, + show (Shape.e P μ) σ = + ((P.dim μ.val : ℂ) / (n.factorial : ℂ)) * + jtChar μ.val (permCast μ.prop.symm σ) from + shape_e_coeff P μ σ, + show (Shape.e P ν) σ = + ((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..56030c712d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/LambdaCoend.lean @@ -0,0 +1,1817 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show α.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 + show α.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) + show G.map + (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ + f = + G.map + (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ + g + rw [← 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) + show (tensorLeft W).map + (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ + f = + (tensorLeft W).map + (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ g + rw [← 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) + show (tensorRight W).map + (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ + f = + (tensorRight W).map + (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ g + rw [← 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 + letI 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 + letI 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] + show ((λ_ (𝟙_ 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 => ?_) + show ((α.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 => ?_) + show (𝟙_ D ◁ lambdaStage α β Y) ≫ + (lambdaUnit α β ▷ lambdaObj α β) ≫ lambdaMul α β = + (𝟙_ D ◁ lambdaStage α β Y) ≫ (λ_ (lambdaObj α β)).hom + rw [lambdaUnit, comp_whiskerRight, comp_whiskerRight] + simp only [Category.assoc] + show (𝟙_ D ◁ lambdaStage α β Y) ≫ + ((λ_ (𝟙_ D)).inv ▷ lambdaObj α β) ≫ + (((ε α ≫ α.map unitRightDualIso.inv) ⊗ₘ ε β) ▷ + lambdaObj α β) ≫ + (lambdaStage α β (𝟙_ A) ▷ lambdaObj α β) ≫ + lambdaMul α β = + (𝟙_ D ◁ lambdaStage α β Y) ≫ (λ_ (lambdaObj α β)).hom + erw [stage_whiskerRight_lambdaMul] + rw [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] + show ((α.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 => ?_) + show (lambdaStage α β X ▷ 𝟙_ D) ≫ + (lambdaObj α β ◁ lambdaUnit α β) ≫ lambdaMul α β = + (lambdaStage α β X ▷ 𝟙_ D) ≫ (ρ_ (lambdaObj α β)).hom + rw [← whisker_exchange_assoc] + erw [stage_whiskerRight_lambdaMul] + rw [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 => ?_) + show (((α.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 => ?_) + show ((α.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). -/ +@[implicit_reducible] +noncomputable def 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 + letI : 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..937c1ceef8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.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 +-/ + +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 : ℕ`. +-/ + +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 + · show (LinearMap.proj (R := ℂ) (φ := fun _ : Fin r => ℂ) + i).comp (LinearMap.single ℂ (fun _ => ℂ) i) = + LinearMap.id + refine LinearMap.ext fun z => ?_ + show 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 → ℂ) _ _ + · show (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 + show 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 + · show (LinearMap.proj (R := ℂ) (φ := fun _ : Fin r => ℂ) + i').comp (LinearMap.single ℂ (fun _ => ℂ) i) = 0 + refine LinearMap.ext fun z => ?_ + show 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 => ?_ + show (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 => ?_ + show (LinearMap.proj (R := ℂ) + (φ := fun _ : Fin r => ℂ) i') + ((0 : (Fin 0 → ℂ) →ₗ[ℂ] (Fin r → ℂ)) z) = 0 + rw [LinearMap.zero_apply, map_zero] + · 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 → ℂ) _ _ + · show (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 + show 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 := 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..18af5e7cd1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffle.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 +-/ + +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. +-/ + +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..fb115898a2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffleLine.lean @@ -0,0 +1,208 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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..bd86b438d6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixSumPow.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle +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. +-/ + +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..fa84d54206 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhisker.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 +-/ + +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. +-/ + +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, dif_pos 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..cd4571ab68 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhiskerAll.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixDegenerate +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. +-/ + +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..4cbbb8350e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedConc.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 +-/ + +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. +-/ + +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 => + show 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 => + show blockEmbed σ 1 (Fin.natAdd a (Fin.last b)) = + extPerm (blockEmbed σ 1) (Fin.last (a + b)) + rw [blockEmbed_natAdd, extPerm_last] + rfl + | cast j => + show 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 + show 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) + show (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 => + show (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 + show 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 + show 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 + show 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 + | hM σ => + induction y using MonoidAlgebra.induction_on with + | hM τ => + 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 σ τ + | hadd y₁ y₂ hy₁ hy₂ => + rw [blockAlgEmbed_add_snd, map_add, map_add] + exact tensor_add_glue hy₁ hy₂ + | hsmul r y' hy => + rw [blockAlgEmbed_smul_snd, map_smul, map_smul] + exact tensor_smul_glue r hy + | hadd x₁ x₂ hx₁ hx₂ => + rw [blockAlgEmbed_add_fst, map_add, map_add] + exact add_tensor_glue hx₁ hx₂ + | hsmul 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..aa40ab7065 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedDiag.lean @@ -0,0 +1,416 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Intertwine +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`. +-/ + +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) + calc (tensorPowDistrib X Y (n + 2)).hom + = ((((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 := rfl + _ = _ := by rw [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 + show 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 + show 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 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 + | hM σ => + rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n))) σ = + MonoidAlgebra.single σ (1 : ℂ) from rfl, + permAlg_single, diagAlg_single] + exact tensorPowDistrib_permMor X Y n σ + | hadd x y hx hy => + rw [map_add, map_add] + exact intertwine_add hx hy + | hsmul 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..c0b5ab4bcd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedTransport.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 +-/ + +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. +-/ + +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..3da2cf4738 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAbelian.lean @@ -0,0 +1,1643 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +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. +-/ + +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 _ _ ?_ + show 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 [dif_pos rfl] + refine Mod.hom_ext _ _ ?_ + show 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 [dif_neg h] + refine Mod.hom_ext _ _ ?_ + show 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 + show 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 + show actLeft A W.X ≫ kernel.lift f.hom k.hom _ + = A ◁ kernel.lift f.hom k.hom _ ≫ 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]) + +/-- 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 + haveI := 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 + haveI := 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 + show 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 + show cokerAct A f ≫ cokernel.desc f.hom k.hom _ + = A ◁ cokernel.desc f.hom k.hom _ ≫ actLeft A W.X + haveI := 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]) + +/-- 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 + haveI := 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 + show 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 + show 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] + haveI : Mono (kernel.ι (f ≫ biprod.snd) ≫ f) := mono_comp _ _ + haveI : 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⟩ + · haveI : 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] + haveI : 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⟩ + · haveI : 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 + haveI := 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 + haveI : Simple (S i) := hS i (List.mem_cons_self ..) + haveI : 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 + haveI := 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 + haveI : Simple (S i) := hS i (List.mem_cons_self ..) + haveI : 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 + show 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 + haveI := 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..00c8bf2541 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAssoc.lean @@ -0,0 +1,568 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 => rw [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] + rw [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 ?_ + show ((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 => rw [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, Category.assoc] + rw [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 => rw [associator_inv_naturality_middle_assoc, + ← MonoidalCategory.comp_whiskerRight_assoc, + whiskerLeft_actRight_modTensorπ, + MonoidalCategory.comp_whiskerRight, + MonoidalCategory.comp_whiskerRight] + simp only [Category.assoc] + conv_lhs => rw [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) + show ((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 => rw [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] + rw [← 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 + show (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 + rw [whiskerRight_modTensorπ_assocMid_assoc, modTensorAssocCover] + simp only [Category.assoc] + erw [modTensorπ_assocInv] + rw [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 + show (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) + rw [whiskerLeft_modTensorπ_assocInvMid_assoc, + modTensorAssocInvCover] + simp only [Category.assoc] + erw [modTensorπ_assocHom] + rw [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 + rw [modTensorAssocCover] + simp only [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 => rw [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 + haveI : 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..1d0a415bf9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModBiprod.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 +-/ + +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. +-/ + +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 + show 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 + show 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 + show (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 + show (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] + show 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 + show 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..44acfe1967 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModContractL.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 +-/ + +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. +-/ + +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 + show ((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 + show ((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 + show (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] + simp only [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 + show (M'.X ◁ ((β_ M.X A).hom ≫ actLeft A M.X)) ≫ + modTensorπ A M' M ≫ p = _ + rw [MonoidalCategory.whiskerLeft_comp, Category.assoc, + reassoc_of% hrel] + show (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 => rw [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..4dba5390b6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModCross.lean @@ -0,0 +1,921 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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 + show (((β_ (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 + show 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] + rfl + +/-- **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 + show (α_ (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 + show 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] + rfl + +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] + show (((α_ 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 + show (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 + show (((β_ (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 + show 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] + rfl + +/-- **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] + show ((((α_ 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' + show (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 + show (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 + show (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 + show (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..82a1a71983 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModDual.lean @@ -0,0 +1,442 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show (β_ 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 + letI := dualModObj A X Y + show 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] + letI := dualModObj A X Y + show (α_ 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..1e73674103 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.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 +-/ + +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. +-/ + +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 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 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 at h4 + rw [h4] + · have := congrArg List.reverse hd + simp 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 + show (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 + show (((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 + show (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..30e9c504ce --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMulti.lean @@ -0,0 +1,1482 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show (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 + show (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 + show ((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 + show 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 + show ((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 + show ((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 + show (((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 + show ((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 + show ((𝟙_ 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)] + show (α_ 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} [Fintype 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 + 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} [Fintype 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 + 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 + show (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 + show (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] + show (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 + exact (Category.assoc _ _ _).trans + ((congrArg (modMultiHeadShuffle A X N post ≫ ·) hrel).trans + (Category.assoc _ _ _).symm) + · rw [List.cons_append] at hd + injection hd with h1 h2 + subst h1 + subst h2 + rw [modMultiLegM, modMultiLegN] + show (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, + modListHeadAct_tail_assoc A X _, 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..922b406090 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMultiTriple.lean @@ -0,0 +1,519 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMulti +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. +-/ + +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 + show (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 + show (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 + show ((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 + show (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 + show (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 + show (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] + rw [← 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 + show (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 ?_ + show ((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] + rw [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] + 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 + show (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..efb785fd9c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowCast.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul +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. +-/ + +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 + | hM σ => + rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n))) σ = + MonoidAlgebra.single σ (1 : ℂ) from rfl, + modPowAlg_single, permAlg_single] + exact modPowπ_perm n σ + | hadd x₁ x₂ h₁ h₂ => + rw [map_add, map_add] + exact add_pass h₁ h₂ + | hsmul 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..ad0d32221e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescent.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing +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. +-/ + +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 + show 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] + rw [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..3cf40f0db0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescentClose.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 +-/ + +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. +-/ + +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..c6629c0cd5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowStage.lean @@ -0,0 +1,220 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show ((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 + show ((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] + simp only [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 + rw [modPowLegFst, modPowLegSnd, desc_whiskerRight, + desc_whiskerRight, Preadditive.sum_comp, Preadditive.sum_comp] + refine Finset.sum_congr rfl fun i _ => ?_ + simp only [Category.assoc] + exact whisker_eq _ (slot_whiskerRight A X i.val (n - 2 - i.val) + (slot_decomp i)) + +/-- **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..61a30ea079 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchur.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GrowthDichotomy +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdemCut +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowCast +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. +-/ + +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..34dfd4455c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchurSummand.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchur +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. +-/ + +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 + haveI := (modBiprodInl A M N).isModHom + haveI := (modBiprodFst A M N).isModHom + refine ModSchurKilled.of_split A (modBiprodInl A M N).hom + (modBiprodFst A M N).hom ?_ P h + show (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 + haveI := e.hom.isModHom + haveI := 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..f79b4c1f63 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean @@ -0,0 +1,1097 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + haveI := 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 [actRight, actLeft_actLeft] + 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 [actRight, actLeft_actLeft] + 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 + show ((β_ 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 + show 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 + show (((λ_ 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 + show (((λ_ 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 + show ((ρ_ (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 + show ((ρ_ (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 + 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 + show 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 + show 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 + show (β_ 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. -/ +@[reassoc (attr := simp)] +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..8aa130a2bc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModZero.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +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. +-/ + +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..9a7925813b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MuInterchange.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 +-/ + +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. +-/ + +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..4334513837 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MulBy.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 +-/ + +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`. +-/ + +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..6f5946104c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NatChain.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 +-/ + +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. +-/ + +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..d341d6fbf0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NewtonConv.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 +-/ + +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. +-/ + +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 : d⁄dX ℂ F = P * F) (hG : d⁄dX ℂ 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..48c7fa1e72 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NullPoint.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 +-/ + +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. +-/ + +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 + haveI := hm + letI := Ideal.Quotient.field m + haveI : Module.Finite ℂ (R ⧸ m) := + finite_of_finite_type_of_isJacobsonRing ℂ (R ⧸ m) + haveI : 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..7dee6feb70 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLineMap.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 +-/ + +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. +-/ + +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..5ef646eb3f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLinePairing.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 +-/ + +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. +-/ + +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 + show (tensorRight Y).map (-𝟙 X) = _ + rw [Functor.map_neg] + simp + rfl + +/-- 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 + show (tensorLeft X).map (-𝟙 Y) = _ + rw [Functor.map_neg] + simp + rfl + +/-- **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..1a7529d10c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddParity.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 +-/ + +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. +-/ + +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 + show L.sq.inv ≫ (((λ_ L.obj).inv ≫ (f ▷ L.obj) ≫ + (α_ M L.obj L.obj).hom ≫ (M ◁ L.sq.hom) ≫ (ρ_ M).hom) + ▷ L.obj) = f + letI := 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 + show (λ_ L.obj).inv ≫ ((L.sq.inv ≫ (g ▷ L.obj)) ▷ L.obj) ≫ + (α_ M L.obj L.obj).hom ≫ (M ◁ L.sq.hom) ≫ (ρ_ M).hom = g + letI := 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..042e91d3f9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddPermSign.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 +-/ + +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. +-/ + +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 + rw [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..d9d1353e8c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquare.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 +-/ + +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. +-/ + +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 + show (α_ 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..fe4a27cf71 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquareIso.lean @@ -0,0 +1,379 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquare +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMu +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaShift +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. +-/ + +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 + show ((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 + show ((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 + show ((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 + show ((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 + show (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)))) = _ + rw [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 + show (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)))) = _ + rw [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 + show (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)))) = _ + rw [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 + show (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)))) = _ + rw [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 + haveI hsh : IsIso (oddSqShift L R) := by + haveI : IsIso (SuperCommAlgebra.Mod.tensorHom + (gammaShiftIso L R).hom (gammaShiftIso L R).hom) := + (SuperCommAlgebra.Mod.tensorIso (gammaShiftIso L R) + (gammaShiftIso L R)).isIso_hom + exact IsIso.comp_isIso + haveI 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] + haveI h1 : IsIso (gammaFunMap L R (freeModMap R L.sq.hom)) := + ((gammaModuleFunctor L R).mapIso + (freeModMapIso R L.sq)).isIso_hom + haveI h2 : IsIso (gammaFunMap L R (freeModUnitIso R).hom) := + ((gammaModuleFunctor L R).mapIso (freeModUnitIso R)).isIso_hom + haveI h3 : IsIso (gammaFunMap L R (freeModMap R L.sq.hom) ≫ + gammaFunMap L R (freeModUnitIso R).hom) := IsIso.comp_isIso + haveI h4 : IsIso (gammaFunMap L R + (freeModTensorIso R L.obj L.obj).hom) := + ((gammaModuleFunctor L R).mapIso + (freeModTensorIso R L.obj L.obj)).isIso_hom + haveI 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..fc69268626 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairCarrier.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 +-/ + +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. +-/ + +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 + rw [chainBGrUnit, ← Category.assoc, + chainBUnit_chainBGrComponentZeroIso_inv, Category.assoc] + show 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..39f8b9bef4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairMul.lean @@ -0,0 +1,672 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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] + show ((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 + simp only [Category.assoc] at hcov' + conv_rhs => rw [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 => rw [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] + show ((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 + rw [← Category.assoc, hcov] + exact (Category.assoc _ _ _).trans + (congrArg (CategoryStruct.comp _) (Category.assoc _ _ _)) + conv_rhs => rw [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] + show ((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 + simp only [Category.assoc] at hcov' + conv_rhs => rw [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 => rw [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] + show ((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 + rw [← 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..00a56460cc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairPerm.lean @@ -0,0 +1,1072 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show 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 + show 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 + show 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] + show ((α_ (𝟙_ 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 + show 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 + rw [rawPair_succ_step, rawPair_succ_step, + ← pairStep_postcomp, MonoidalCategory.whiskerLeft_comp] + simp only [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 + rw [hpair, hts, ← whisker_exchange_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc, hlow] + conv_rhs => rw [MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rw [hdbl] + +/-- **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] + rw [← whisker_exchange_assoc, hstep] + rw [← 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] + rfl + 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] + rfl + 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..216f619f2d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermNat.lean @@ -0,0 +1,390 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Intertwine +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing +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. +-/ + +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 => + haveI : PreservesLimitsOfSize.{0, 0} (tensorRight X) := + preservesSmallestLimits_of_preservesLimits _ + haveI : PreservesLimitsOfSize.{0, 0} + (tensorLeft (tensorPow A Y n)) := + preservesSmallestLimits_of_preservesLimits _ + haveI := ih + haveI : Mono (tensorPowMap f n ▷ X) := + (tensorRight X).map_mono (tensorPowMap f n) + haveI : Mono (tensorPow A Y n ◁ f) := + (tensorLeft (tensorPow A Y n)).map_mono f + rw [tensorPowMap_succ, MonoidalCategory.tensorHom_def] + show 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 => + haveI := ih + haveI : Mono (tensorPowMap f n ▷ X) := + (tensorRight X).map_mono (tensorPowMap f n) + haveI : Mono (tensorPow A Y n ◁ f) := + (tensorLeft (tensorPow A Y n)).map_mono f + rw [tensorPowMap_succ, MonoidalCategory.tensorHom_def] + show 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 => + haveI : PreservesColimitsOfSize.{0, 0} (tensorRight X) := + preservesSmallestColimits_of_preservesColimits _ + haveI : PreservesColimitsOfSize.{0, 0} + (tensorLeft (tensorPow A Y n)) := + preservesSmallestColimits_of_preservesColimits _ + haveI := ih + haveI : Epi (tensorPowMap f n ▷ X) := + (tensorRight X).map_epi (tensorPowMap f n) + haveI : Epi (tensorPow A Y n ◁ f) := + (tensorLeft (tensorPow A Y n)).map_epi f + rw [tensorPowMap_succ, MonoidalCategory.tensorHom_def] + show 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 σ + show 𝟙 (𝟙_ 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 + | hM σ => + rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n))) σ = + MonoidAlgebra.single σ (1 : ℂ) from rfl, + permAlg_single, permAlg_single] + exact permMor_natural f n σ + | hadd x y hx hy => + rw [map_add, map_add] + exact intertwine_add hx hy + | hsmul 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 + haveI := 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 + haveI := 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..c9943e86f0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermRepChar.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CharSplit +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSeries +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. +-/ + +namespace RS + +open Finset Equiv MonoidAlgebra + +open scoped Classical + +/-! ### 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 + show g ∘ ⇑(1 : Equiv.Perm (Fin n))⁻¹ = g + simp + mul_smul π ρ g := by + show 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 + show 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 + show LinearMap.trace ℂ _ ((permRep p n) π) = _ + set b := MonoidAlgebra.basis (colourSpace n p) ℂ with hb_def + rw [LinearMap.trace_eq_matrix_trace ℂ b] + show ∑ 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] + show ((coeffLinearEquiv ℂ) + (MonoidAlgebra.single (π • g) (1 : ℂ))) g = + if π • g = g then 1 else 0 + rw [coeffLinearEquiv_apply] + simp [MonoidAlgebra.coeff, Finsupp.single_apply, eq_comm] + rw [Finset.sum_congr rfl (fun g _ => hdiag g)] + rw [← Finset.sum_filter] + simp + +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 => ?_ + show ((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 + show 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 + show 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 + show (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 + haveI : 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 + haveI : 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..75fae416a7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PieriPos.lean @@ -0,0 +1,1529 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookZero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.NewtonConv +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. +-/ + +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 + show 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 [if_pos hjk, if_pos hjk.symm, mul_one] + · rw [if_neg hjk, if_neg (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), + if_pos (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, dif_pos 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 [if_pos hμ, if_pos hμ, one_mul] + · rw [if_neg hμ, if_neg 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 + rw [Finset.mem_filter] + exact ⟨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_upperTriangular (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 [dif_pos 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 [if_pos h1, if_pos h1, one_mul, + if_neg (fun he => by + have hv : (i : ℕ) = (i : ℕ) + 1 := + congrArg Fin.val (h1.symm.trans he) + omega), + add_zero] + · rw [if_neg h1, if_neg h1] + by_cases h2 : (k : ℕ) = (i : ℕ) + 1 + · rw [if_pos h2, if_pos (Fin.ext h2), neg_one_mul, zero_add] + · rw [if_neg h2, + if_neg (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), + if_pos (Finset.mem_univ i), + Finset.sum_ite_eq' Finset.univ (⟨(i : ℕ) + 1, h⟩ : Fin ℓ) + (fun k => -M k j), + if_pos (Finset.mem_univ _)] + ring + · rw [dif_neg 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 [if_pos h1, if_pos h1, one_mul] + · rw [if_neg h1, if_neg h1, + if_neg (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), + if_pos (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 [dif_pos h] + show 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 [dif_neg 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 + show 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 + show 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 +/-- **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] + show 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 + show 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 : ∀ 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 + 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 + show 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 + -- 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] + show 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 + show (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 + show ((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 + show ((r i).toNat : ℤ) = r i + omega + · intro s _ + funext i + show ((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 [if_neg (fun hle => hne (shape_eq_rowShape ν hle)), + mul_zero]) + (fun h => absurd (Finset.mem_univ _) h)] + rw [if_pos (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 [if_neg (fun hle => hne (shape_eq_colShape ν hle)), + mul_zero]) + (fun h => absurd (Finset.mem_univ _) h)] + rw [if_pos (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 [dif_pos (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 [dif_pos (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 ?_ + show 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 [if_pos hμ, one_mul] + exact diagramSchur_superPS_exists_nat p 0 μ.val + · rw [if_neg 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 [if_pos hμ, one_mul] + exact diagramSchur_superPS_exists_nat p 0 μ.val + · rw [if_neg hμ, zero_mul] + exact ⟨0, by simp⟩ + · refine ⟨m₀, hm₀, ?_⟩ + show (if IsHStrip lam (stripDiagram r₀) then (1 : ℂ) + else 0) * diagramSchur (stripDiagram r₀) + (superPS p 0) = (m₀ : ℂ) + rw [if_pos 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 + show (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⟩] + show (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⟩] + show 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⟩] + show (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 [if_pos hμ, one_mul] + exact diagramSchur_superPS_exists_nat p q μ.val + · rw [if_neg 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 [if_pos hμ, one_mul] + exact diagramSchur_superPS_exists_nat p q μ.val + · rw [if_neg hμ, zero_mul] + exact ⟨0, by simp⟩ + · refine ⟨m₀, hm₀, ?_⟩ + show (if IsVStrip lam (stripDiagram r₁) then (1 : ℂ) + else 0) * diagramSchur (stripDiagram r₁) + (superPS p q) = (m₀ : ℂ) + rw [if_pos 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..8d5fa67420 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PlainShuffle.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 +-/ + +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. +-/ + +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..7ff5524291 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointBaseChange.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairAdd +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShiftUnit +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`. +-/ + +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 + show 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. -/ +@[nolint unusedArguments] +noncomputable def toSuperVect (P : SuperPoint S) + (M : S.Mod.{u, u, u, u}) + [FiniteDimensional ℂ (M.tensor (pointMod P)).even] + [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] : + 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] + show 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] + show 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..e19bb1aef4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointFibre.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverComplex +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. +-/ +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 => ?_ + · show (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 + · show (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 => ?_ + · show (toSuperVectEvenEquiv P Q) + (((tensorRightFunctor (pointMod P)).map (u ≫ v)).evenMap + ((toSuperVectEvenEquiv P M).symm x)) = _ + rw [CategoryTheory.Functor.map_comp] + show _ = (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))))) + rw [LinearEquiv.symm_apply_apply] + rfl + · show (toSuperVectOddEquiv P Q) + (((tensorRightFunctor (pointMod P)).map (u ≫ v)).oddMap + ((toSuperVectOddEquiv P M).symm x)) = _ + rw [CategoryTheory.Functor.map_comp] + show _ = (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))))) + rw [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 => ?_ + · show (toSuperVectEvenEquiv P N) + (((tensorRightFunctor (pointMod P)).map (u + v)).evenMap + ((toSuperVectEvenEquiv P M).symm x)) = _ + rw [CategoryTheory.Functor.map_add] + show (toSuperVectEvenEquiv P N) + ((((tensorRightFunctor (pointMod P)).map u).evenMap + + ((tensorRightFunctor (pointMod P)).map v).evenMap) + ((toSuperVectEvenEquiv P M).symm x)) = _ + exact map_add _ _ _ + · show (toSuperVectOddEquiv P N) + (((tensorRightFunctor (pointMod P)).map (u + v)).oddMap + ((toSuperVectOddEquiv P M).symm x)) = _ + rw [CategoryTheory.Functor.map_add] + show (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 => ?_ + · show (toSuperVectEvenEquiv P N) + (((tensorRightFunctor (pointMod P)).map (c • u)).evenMap + ((toSuperVectEvenEquiv P M).symm x)) = _ + rw [CategoryTheory.Functor.map_smul] + show (toSuperVectEvenEquiv P N) + ((c • ((tensorRightFunctor (pointMod P)).map u).evenMap) + ((toSuperVectEvenEquiv P M).symm x)) = _ + exact map_smul (toSuperVectEvenEquiv P N) c _ + · show (toSuperVectOddEquiv P N) + (((tensorRightFunctor (pointMod P)).map (c • u)).oddMap + ((toSuperVectOddEquiv P M).symm x)) = _ + rw [CategoryTheory.Functor.map_smul] + show (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) (hE X) (hO X) + map {X Y} f := + @superVectHom _ P _ _ (hE X) (hO X) (hE Y) (hO Y) (G.map f) + map_id X := by + show @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 + show @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) (hE X) (hO 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 + show @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.Additive] [G.Linear ℂ] : + (superVectFunctor P G hE hO).Linear ℂ where + map_smul {X Y} f c := by + show @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 + haveI : (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 + haveI : 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]⟩ + haveI : 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 + haveI : (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..339594c84c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal.lean @@ -0,0 +1,24 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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..2360c7a44b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Calculus.lean @@ -0,0 +1,566 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show 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 + show 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..b2f01c6c0f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean @@ -0,0 +1,1319 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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}) + +/-- **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 + refine SuperVect.hom_ext + (superVectTripleEven_ext (fun a b c => ?_) (fun a b c => ?_) + (fun a b c => ?_) (fun a b c => ?_)) + (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.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, svComp_oddMap_apply, + svWhiskerRight_evenMap_inl, svWhiskerRight_evenMap_inr, + svWhiskerRight_oddMap_inl, svWhiskerRight_oddMap_inr, + svWhiskerLeft_evenMap_inl, svWhiskerLeft_evenMap_inr, + svWhiskerLeft_oddMap_inl, svWhiskerLeft_oddMap_inr, + svAssoc_evenMap_ee, svAssoc_evenMap_oo, svAssoc_evenMap_eo, + svAssoc_evenMap_oe, svAssoc_oddMap_ee, svAssoc_oddMap_oo, + svAssoc_oddMap_eo, svAssoc_oddMap_oe, + superVectMu_evenMap_ee, superVectMu_evenMap_oo, + superVectMu_oddMap_eo, superVectMu_oddMap_oe, + superVectHom_evenMap_apply, superVectHom_oddMap_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)) + (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, svComp_oddMap_apply, + svWhiskerRight_evenMap_inl, svWhiskerRight_evenMap_inr, + svWhiskerRight_oddMap_inl, svWhiskerRight_oddMap_inr, + svWhiskerLeft_evenMap_inl, svWhiskerLeft_evenMap_inr, + svWhiskerLeft_oddMap_inl, svWhiskerLeft_oddMap_inr, + svAssoc_evenMap_ee, svAssoc_evenMap_oo, svAssoc_evenMap_eo, + svAssoc_evenMap_oe, svAssoc_oddMap_ee, svAssoc_oddMap_oo, + svAssoc_oddMap_eo, svAssoc_oddMap_oe, + superVectMu_evenMap_ee, superVectMu_evenMap_oo, + superVectMu_oddMap_eo, superVectMu_oddMap_oe, + superVectHom_evenMap_apply, superVectHom_oddMap_apply, + LinearEquiv.symm_apply_apply] + rw [key, superVectMu_evenMap_oo, + 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)) + (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, svComp_oddMap_apply, + svWhiskerRight_evenMap_inl, svWhiskerRight_evenMap_inr, + svWhiskerRight_oddMap_inl, svWhiskerRight_oddMap_inr, + svWhiskerLeft_evenMap_inl, svWhiskerLeft_evenMap_inr, + svWhiskerLeft_oddMap_inl, svWhiskerLeft_oddMap_inr, + svAssoc_evenMap_ee, svAssoc_evenMap_oo, svAssoc_evenMap_eo, + svAssoc_evenMap_oe, svAssoc_oddMap_ee, svAssoc_oddMap_oo, + svAssoc_oddMap_eo, svAssoc_oddMap_oe, + superVectMu_evenMap_ee, superVectMu_evenMap_oo, + superVectMu_oddMap_eo, superVectMu_oddMap_oe, + superVectHom_evenMap_apply, superVectHom_oddMap_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, svComp_oddMap_apply, + svWhiskerRight_evenMap_inl, svWhiskerRight_evenMap_inr, + svWhiskerRight_oddMap_inl, svWhiskerRight_oddMap_inr, + svWhiskerLeft_evenMap_inl, svWhiskerLeft_evenMap_inr, + svWhiskerLeft_oddMap_inl, svWhiskerLeft_oddMap_inr, + svAssoc_evenMap_ee, svAssoc_evenMap_oo, svAssoc_evenMap_eo, + svAssoc_evenMap_oe, svAssoc_oddMap_ee, svAssoc_oddMap_oo, + svAssoc_oddMap_eo, svAssoc_oddMap_oe, + superVectMu_evenMap_ee, superVectMu_evenMap_oo, + superVectMu_oddMap_eo, superVectMu_oddMap_oe, + superVectHom_evenMap_apply, superVectHom_oddMap_apply, + LinearEquiv.symm_apply_apply] + rw [key, superVectMu_evenMap_oo, + LinearEquiv.symm_apply_apply] + 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)) + (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_evenMap_apply, svComp_oddMap_apply, + svWhiskerRight_evenMap_inl, svWhiskerRight_evenMap_inr, + svWhiskerRight_oddMap_inl, svWhiskerRight_oddMap_inr, + svWhiskerLeft_evenMap_inl, svWhiskerLeft_evenMap_inr, + svWhiskerLeft_oddMap_inl, svWhiskerLeft_oddMap_inr, + svAssoc_evenMap_ee, svAssoc_evenMap_oo, svAssoc_evenMap_eo, + svAssoc_evenMap_oe, svAssoc_oddMap_ee, svAssoc_oddMap_oo, + svAssoc_oddMap_eo, svAssoc_oddMap_oe, + superVectMu_evenMap_ee, superVectMu_evenMap_oo, + superVectMu_oddMap_eo, superVectMu_oddMap_oe, + superVectHom_evenMap_apply, superVectHom_oddMap_apply, + LinearEquiv.symm_apply_apply] + rw [key, superVectMu_oddMap_eo, + LinearEquiv.symm_apply_apply] + 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_evenMap_apply, svComp_oddMap_apply, + svWhiskerRight_evenMap_inl, svWhiskerRight_evenMap_inr, + svWhiskerRight_oddMap_inl, svWhiskerRight_oddMap_inr, + svWhiskerLeft_evenMap_inl, svWhiskerLeft_evenMap_inr, + svWhiskerLeft_oddMap_inl, svWhiskerLeft_oddMap_inr, + svAssoc_evenMap_ee, svAssoc_evenMap_oo, svAssoc_evenMap_eo, + svAssoc_evenMap_oe, svAssoc_oddMap_ee, svAssoc_oddMap_oo, + svAssoc_oddMap_eo, svAssoc_oddMap_oe, + superVectMu_evenMap_ee, superVectMu_evenMap_oo, + superVectMu_oddMap_eo, superVectMu_oddMap_oe, + superVectHom_evenMap_apply, 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_evenMap_apply, svComp_oddMap_apply, + svWhiskerRight_evenMap_inl, svWhiskerRight_evenMap_inr, + svWhiskerRight_oddMap_inl, svWhiskerRight_oddMap_inr, + svWhiskerLeft_evenMap_inl, svWhiskerLeft_evenMap_inr, + svWhiskerLeft_oddMap_inl, svWhiskerLeft_oddMap_inr, + svAssoc_evenMap_ee, svAssoc_evenMap_oo, svAssoc_evenMap_eo, + svAssoc_evenMap_oe, svAssoc_oddMap_ee, svAssoc_oddMap_oo, + svAssoc_oddMap_eo, svAssoc_oddMap_oe, + superVectMu_evenMap_ee, superVectMu_evenMap_oo, + superVectMu_oddMap_eo, superVectMu_oddMap_oe, + superVectHom_evenMap_apply, superVectHom_oddMap_apply, + LinearEquiv.symm_apply_apply] + rw [key, superVectMu_oddMap_eo, + 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)) + (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_evenMap_apply, svComp_oddMap_apply, + svWhiskerRight_evenMap_inl, svWhiskerRight_evenMap_inr, + svWhiskerRight_oddMap_inl, svWhiskerRight_oddMap_inr, + svWhiskerLeft_evenMap_inl, svWhiskerLeft_evenMap_inr, + svWhiskerLeft_oddMap_inl, svWhiskerLeft_oddMap_inr, + svAssoc_evenMap_ee, svAssoc_evenMap_oo, svAssoc_evenMap_eo, + svAssoc_evenMap_oe, svAssoc_oddMap_ee, svAssoc_oddMap_oo, + svAssoc_oddMap_eo, svAssoc_oddMap_oe, + superVectMu_evenMap_ee, superVectMu_evenMap_oo, + superVectMu_oddMap_eo, superVectMu_oddMap_oe, + superVectHom_evenMap_apply, superVectHom_oddMap_apply, + LinearEquiv.symm_apply_apply] + rw [key, superVectMu_oddMap_oe, + LinearEquiv.symm_apply_apply] + rfl + +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 + show 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 + show (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 + · show 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 + · show superVectMuEvenRaw P M N (baseNuFee P M N m n a) = _ + rw [baseNuFee_apply, map_smul] + show 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 + · show superVectMuEvenRaw P M N (baseNuFoo P M N m n a) = _ + rw [baseNuFoo_apply, map_smul] + show 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] + show 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] + show superVectMuOddRaw P M N (baseNuOdd P M N 0) = 0 + rw [map_zero, map_zero] + · show 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 + · show superVectMuOddRaw P M N (baseNuFeo P M N m n a) = _ + rw [baseNuFeo_apply, map_smul] + show 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 + · show superVectMuOddRaw P M N (baseNuFoe P M N m n a) = _ + rw [baseNuFoe_apply, map_smul] + show 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 => ?_) + · show 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, + baseNuEven_tmulEE, baseNuInnerEven_tmulEE, baseNuFee_apply] + show (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] + · show 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, + baseNuEven_tmulEE, baseNuInnerEven_tmulOO, baseNuFoo_apply] + show (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] + · show 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, + baseNuOdd_tmulOE, baseNuInnerOdd_tmulEO, baseNuFeo_apply] + show (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 => ?_) + · show 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, + baseNuOdd_tmulOE, baseNuInnerOdd_tmulOE, baseNuFoe_apply] + show (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 + show (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] + show 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 + show (leftUnitorHom (pointMod P)).evenMap + ((pointBaseEps P).evenMap (c • S.one)) = _ + rw [h1, leftUnitorHom_evenMap_tmulEE] + refine ULift.ext _ _ ?_ + show P.chi (c • S.one) * 1 = c + rw [mul_one, map_smul] + show 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 + haveI : 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 + haveI : 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 + haveI : 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..a1b4786b2f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Comparison.lean @@ -0,0 +1,806 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show a.down • (x + y) = a.down • x + a.down • y + exact smul_add _ _ _ + map_smul' c x := LinearMap.ext fun a => by + show 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 + show 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 + show 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 => ?_) + · show (SuperCommAlgebra.Mod.tensorHom uu vv).evenMap + (tmulEE A B x y) = _ + rw [tensorHom_evenMap_tmulEE] + rfl + · show (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 => ?_) + · show (SuperCommAlgebra.Mod.tensorHom uu vv).oddMap + (tmulEO A B x y) = _ + rw [tensorHom_oddMap_tmulEO] + rfl + · show (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 + show (0 : basePairEven P M N) = _ + rw [pointMod_actOO, map_zero]) + (fun c t a => by + show 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 + show baseNuInnerOdd P M N ((M.tensor N).actOE c t) a = 0 + rw [baseNuInnerOdd_actOE]) + (fun c t v => by + show (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..f46de953ae --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Functor.lean @@ -0,0 +1,283 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show (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 + letI : ((indOf : C ⥤ Ind C) ⋙ fibreOver L 𝔸).Braided := + { toMonoidal := indFibreMonoidal L 𝔸 hsp + braided := Functor.LaxBraided.braided } + haveI hE : ∀ X, FiniteDimensional ℂ + ((((indOf : C ⥤ Ind C) ⋙ fibreOver L 𝔸).obj X).tensor + (pointMod pt)).even := + finiteDimensional_indFibre_even L 𝔸 hsp pt + haveI 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..35b1cc7e56 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean @@ -0,0 +1,597 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show (a.down + b.down) * c.down = _ + exact add_mul _ _ _)) + (fun r a b => ULift.ext _ _ (by + show (r * a.down) * b.down = r * (a.down * b.down) + exact mul_assoc _ _ _)) + (fun a b c => ULift.ext _ _ (by + show a.down * (b.down + c.down) = _ + exact mul_add _ _ _)) + (fun r a b => ULift.ext _ _ (by + show 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 + show 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] + show (0 : (pointMod P).even) = pointMulLin P m 0 + rw [map_zero] + hooe c m n := by + rw [pointMod_actOO] + show 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 + show P.chi a * m.down * n.down = P.chi a * (m.down * n.down) + ring) + aoo a m n := by + show (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 + show 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 + show 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 + show (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))) + rw [e1, e2, e3, pointMulHom_evenMap_tmulEE, + pointMulHom_evenMap_tmulEE] + refine ULift.ext _ _ ?_ + show 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, + 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, + 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] + show 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..954e60c606 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointTensor.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 +-/ + +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. +-/ + +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 + haveI := 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 + haveI : Mono u := mono_of_point_ne_zero hu hu0 + haveI : Mono v := mono_of_point_ne_zero hu hv0 + haveI hR : (tensorRight (𝟙_ A)).PreservesMonomorphisms := + Functor.preservesMonomorphisms_of_adjunction + (tensorRightAdjunction (ᘁ(𝟙_ A)) (𝟙_ A)) + haveI 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 + haveI := 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..88277e97b8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowAct.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 +-/ + +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. +-/ + +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 ⊢ + exact 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 + | hM σ => + rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin (n + 1)))) σ = + MonoidAlgebra.single σ (1 : ℂ) from rfl, modPowAlg_single] + exact modPowAct_perm A X n σ + | hadd z₁ z₂ h₁ h₂ => + rw [map_add] + exact whisker_act_add (modPowAct A X n) h₁ h₂ + | hsmul 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..1dca1b5d52 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowActMul.lean @@ -0,0 +1,391 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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..3f64d1ddfb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowChain.lean @@ -0,0 +1,272 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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] + show (((β_ (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 + show (α_ 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..5d3144a6fb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowCopairing.lean @@ -0,0 +1,233 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 => simp only [Category.assoc] + 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..5d82705372 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowDatum.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZig +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. +-/ + +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..fde23d2755 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowInduct.lean @@ -0,0 +1,129 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainNonzero +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairSucc +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSuccMod +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. +-/ + +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 ?_ ?_ + · show 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] + · show 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..fe04a8b2bc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowMerge.lean @@ -0,0 +1,1358 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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] + rw [leftUnitor_inv_naturality_assoc, reassoc_of% hcombine'] + 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 + show ((ρ_ X).hom ≫ (λ_ X).inv) ≫ modPowπ A X 1 = _ + rw [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 + rw [h0, MonoidalCategory.whiskerLeft_comp, Category.assoc, + ← actLeft_modPowOne_inv, reassoc_of% hu, reassoc_of% 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) + show (modPowπ A X (a + 1) ▷ A) ≫ + ((β_ (modPow A X (a + 1)) A).hom ≫ + actLeft A (modPowMod A X a).X) = _ + rw [← 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..d79e6e0d2c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairSucc.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 +-/ + +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. +-/ + +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]) + rw [← Category.assoc, tensorHom_π_interchange, + rawInterchangeπ, rawInterchange, Category.assoc, + Category.assoc] + exact 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 + +/-- **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 + rw [← Category.assoc, + MonoidalCategory.tensorHom_comp_tensorHom] + -- The successor pairing against the swapped projection. + 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 + rw [tensorHom_π_interchange_assoc, rawInterchangeπ, + rawInterchange] + simp only [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. + 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 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. + have hmeet := hL2.symm.trans (hcov.trans hR2) + -- Braid the merged pair across the successor braiding. + 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. + 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. + 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..e1421bba84 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean @@ -0,0 +1,1940 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma +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. +-/ + +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] + show (ρ_ (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] + show ((α_ (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] + simp only [Category.assoc] + show (α_ (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] + show ((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 = _ + simp only [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 => simp only [Category.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 => simp only [Category.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 => simp only [Category.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) = _ + simp only [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] + show ((𝟙_ 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 => simp only [Category.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] + show (((ρ_ (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, Category.assoc, cancel_epi] + show ((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] + show ((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) = _ + rw [associator_inv_naturality_left_assoc, + associator_inv_naturality_left_assoc] + simp only [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] + show (((α_ (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, Category.assoc, cancel_epi] + rw [rawPair_succ_step] + show ((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)] + rw [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 + show ((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 + rw [← MonoidalCategory.whiskerLeft_comp_assoc, + ← MonoidalCategory.whiskerLeft_comp_assoc] + conv_lhs => simp only [Category.assoc] + rw [leg_step_snd_eq w a b] + rw [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp] + simp only [Category.assoc] + rfl + 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] + show 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] + show ((α_ 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 => rw [← MonoidalCategory.whiskerLeft_comp_assoc, + hact] + conv_lhs => simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + show ((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 => rw [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 => simp only [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 => rw [← MonoidalCategory.whiskerLeft_comp_assoc, + powTailAct_peel A] + conv_lhs => simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + show ((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 => rw [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 => simp only [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] + show (β_ (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) + (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] + letI := modPowModObj A M'.X n + letI := modPowModObj A M.X n + show (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 ?_ + rw [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..97f697cf7e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPoint.lean @@ -0,0 +1,377 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermNat +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. +-/ + +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 + rw [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 + haveI := 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 + haveI := 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) + calc (tensorPowPoint pt m ⊗ₘ tensorPowPoint pt (n + 1)) ≫ + (tensorPowConcat Y m (n + 1)).hom + = (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) := by + rw [hsucc] + rfl + _ = ((𝟙 (𝟙_ D)) ⊗ₘ (ρ_ (𝟙_ D)).inv) ≫ + ((tensorPowPoint pt m ⊗ₘ + (tensorPowPoint pt n ⊗ₘ pt)) ≫ + (α_ (tensorPow D Y m) (tensorPow D Y n) Y).inv) ≫ + ((tensorPowConcat Y m n).hom ▷ Y) := by + rw [hdec] + simp only [Category.assoc] + _ = ((𝟙 (𝟙_ D)) ⊗ₘ (ρ_ (𝟙_ D)).inv) ≫ + (α_ (𝟙_ D) (𝟙_ D) (𝟙_ D)).inv ≫ + (((tensorPowPoint pt m ⊗ₘ + tensorPowPoint pt n) ⊗ₘ pt) ≫ + ((tensorPowConcat Y m n).hom ▷ Y)) := by + rw [hα] + simp only [Category.assoc] + _ = ((𝟙 (𝟙_ D)) ⊗ₘ (ρ_ (𝟙_ D)).inv) ≫ + (α_ (𝟙_ D) (𝟙_ D) (𝟙_ D)).inv ≫ + (((λ_ (𝟙_ D)).hom ≫ tensorPowPoint pt (m + n)) ⊗ₘ + pt) := by + rw [hIH] + _ = ((𝟙 (𝟙_ D)) ⊗ₘ (ρ_ (𝟙_ D)).inv) ≫ + (α_ (𝟙_ D) (𝟙_ D) (𝟙_ D)).inv ≫ + ((λ_ (𝟙_ D)).hom ▷ (𝟙_ D)) ≫ + (tensorPowPoint pt (m + n) ⊗ₘ pt) := by + rw [← MonoidalCategory.tensorHom_id + ((λ_ (𝟙_ D)).hom), + MonoidalCategory.tensorHom_comp_tensorHom, + Category.id_comp] + _ = (λ_ (𝟙_ D)).hom ≫ (ρ_ (𝟙_ D)).inv ≫ + (tensorPowPoint pt (m + n) ⊗ₘ pt) := by + rw [reassoc_of% hcoh] + +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] + show 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 + haveI := 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 + haveI := 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..faf6d22ca7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSucc.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBofA +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. +-/ + +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) ?_ + rw [reassoc_of% hpt] + show _ = powUnitStage A M M' d n ≫ powDelta A M M' d n + rw [powDelta] + simp only [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..d1db4a4147 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSuccMod.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 +-/ + +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. +-/ + +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 + haveI : 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 + show 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 + show 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 + show 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 + show 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..bf4fda3e2b --- /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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain +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. +-/ + +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 _ + rw [modPowOne, Iso.trans_inv] + rfl + rw [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] + show ((λ_ 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 + rw [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 + show 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 f g = _ + refine congrArg (CategoryStruct.comp _) ?_ + refine (congrArg (CategoryStruct.comp _) h6).trans ?_ + rw [← Category.assoc] + show ((modTensorπ A N₁ P₁ ⊗ₘ modTensorπ A N₂ P₂) ≫ + (f.hom ⊗ₘ g.hom)) ≫ modTensorπ A Q R = _ + rw [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 + show 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 + show 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] + simp only [← 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] + show ((𝟙_ 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 + show (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] + simp only [Category.assoc] + rfl + 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 + show (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] + 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 + letI := 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] + show (α_ 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..36a3578ae0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZig.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 +-/ + +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. +-/ + +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] + show (ρ_ 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] + haveI := 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..e958002c91 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZigzag.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 +-/ + +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. +-/ + +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..bd7b1fac19 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PresentedQuotient.lean @@ -0,0 +1,335 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`). +-/ + +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 α + show 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 + haveI : ∀ i : I, Mono ((imageDiagHom f hf).app i) := fun i => + inferInstanceAs (Mono (image.ι (f i))) + haveI : Mono (imageDiagHom f hf) := NatTrans.mono_of_mono_app _ + haveI : 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) + haveI : 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) + haveI : 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 + show 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 + letI := hcat + letI := hfil + letI := 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 + letI := hcat + letI := hfil + letI := 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..05b95a34ad --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21Core +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverSplitting +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. +-/ + +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 + letI := linearOfScalarUnit ψ + letI := monoidalLinearOfScalarUnitBraided ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + obtain ⟨𝔸, hmon, hcomm, hne, hsp, hsec⟩ := + exists_fibre_algebra ψ P P₀ L hkill + letI := hmon + letI := hcomm + haveI hmono : Mono η[𝔸] := + mono_unit_ind (simple_unit_of_hasScalarUnit + (hasScalarUnit_of_scalarUnit ψ)) 𝔸 hne + haveI 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..d0b305dc80 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21Core.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplittingAlgebra +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndLocallyMixed +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplitSection +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndUnitNonzero +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. +-/ + +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 + letI := linearOfScalarUnit ψ + letI := monoidalLinearOfScalarUnitBraided ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := 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..4c2473bf82 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21General.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21 +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledLine +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledScalar +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledGrowth +import LeanPool.RegtsSevenster.RS.Classical.Deligne.EvenEmbedMonoidal +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLineMap +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. +-/ + +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 + letI := linearOfScalarUnit (doubledScalarUnit hu) + letI := monoidalLinearOfScalarUnitBraided (doubledScalarUnit hu) + letI := linearOfScalarUnit (indScalarUnit (doubledScalarUnit hu)) + letI := 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)) + letI := hmon + letI := hcomm + letI := hM + letI := hL + letI := hCo + letI := 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..44b7985daf --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29.lean @@ -0,0 +1,102 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaData +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. +-/ + +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..d4df9b3d88 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29Close.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DevissageBound +import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepB +import LeanPool.RegtsSevenster.RS.Classical.Deligne.DescentClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitState +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. +-/ + +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..ff893ab488 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29State.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 +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. +-/ + +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 + letI := st.monObj + letI := 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 + show (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 + show (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..3821ea537d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210.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 +-/ + +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. +-/ + +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. -/ +@[nolint unusedArguments] +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..296a97b3d7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Bridge.lean @@ -0,0 +1,197 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoverFactor +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. +-/ + +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] + simp only [Category.assoc] + exact (Category.assoc _ _ _).symm + +/-- **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] + calc splitUnitStage Y pt (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 + _ = (ρ_ (𝟙_ 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 := 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 _))))) + _ = (ρ_ (𝟙_ 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 + _ = (ρ_ (𝟙_ 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] + _ = (ρ_ (𝟙_ 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] + _ = 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 _))) + +/-- 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..00c0669a36 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Chain.lean @@ -0,0 +1,439 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul +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. +-/ + +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 + show (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 + rw [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 + show (β_ (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] + show 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..a0a80b4be5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Close.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Bridge +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. +-/ + +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 + letI : MonObj (rappel210Algebra S) := + splitAlgebraMonObj (((unitFormMid S)ᘁ : D)) + (unitFormPoint S) + haveI : 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..c280584cbf --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Ind.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBInd +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. +-/ + +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 + haveI 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..3540659219 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Reduce.lean @@ -0,0 +1,768 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPoint +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. +-/ + +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 + haveI := tensorLeftPreservesColimits X + haveI := tensorLeftPreservesLimits X + haveI : PreservesFiniteColimits (tensorLeft X) := + PreservesColimitsOfSize.preservesFiniteColimits _ + haveI : 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₃)ᘁ) + haveI hmf : Mono (((S.X₃)ᘁ) ◁ S.f) := hT.mono_f + haveI : Mono ((S.map (tensorLeft ((S.X₃)ᘁ))).f) := hT.mono_f + haveI 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 + haveI 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₃)) + haveI : 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 + haveI := hf + constructor + intro W a b h + haveI : 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 + calc 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 _ _ _)))) + _ = (B ◁ (pointSection S B cls ≫ + (β_ (unitFormMid S) B).hom ≫ + (B ◁ (unitForm S).g))) ≫ + (α_ B B (𝟙_ D)).inv ≫ (μ[B] ▷ (𝟙_ D)) := by + simp only [MonoidalCategory.whiskerLeft_comp, + Category.assoc] + _ = (B ◁ ((ρ_ (𝟙_ D)).inv ≫ (η[B] ▷ (𝟙_ D)))) ≫ + (α_ B B (𝟙_ D)).inv ≫ (μ[B] ▷ (𝟙_ D)) := by + rw [hinner] + rfl + _ = 𝟙 (B ⊗ 𝟙_ D) := 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 + show ((α_ 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 + show (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 + rw [← 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 + rw [freeSectionPoint] + simp only [Category.assoc] + exact whisker_eq _ (whisker_eq _ + ((whisker_eq _ hpull).trans + ((Category.assoc _ _ _).symm.trans + ((eq_whisker hsec _).trans (Category.id_comp _))))) + +/-- **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 + show ((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..078e9c7b34 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean @@ -0,0 +1,1185 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeAlgebra +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly +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. +-/ + +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⟩ + show 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 : MvPolynomial.coeff + (∑ i, Finsupp.single i (eVec lam k i)) + (altDet (eVec lam k)) = 1 := by + rw [alternant_coeff_strict _ _ (eVec_strict lam k) + (eVec_strict lam k), if_pos 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 [if_neg 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 + show Finsupp.mapDomain + (⇑(Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h))) x = x + 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 g = x ((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] [Fintype G] + [DecidableEq 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.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.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 [if_neg (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 (coeff (cycExp π₀)) hp0 + rw [hp, coeff_sum, 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 [if_pos hπ, if_pos 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 [if_neg hπ, if_neg 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 => ?_ + show 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] + show 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 [if_neg hiso, zero_smul, smul_zero] + rw [if_pos 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ρ' + haveI hirr' : ρ'.IsIrreducible := + isIrreducible_comp_permCastHom hm (rhoS T) + (rhoS_isIrreducible T hT) + haveI 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 + haveI : 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, if_neg 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 [if_pos rfl] + · rw [if_neg (fun h => hk h.symm), if_neg 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 [if_pos rfl, if_pos (by group)] + · rw [if_neg hg, if_neg (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 + haveI : 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 + show symCast (le_of_eq μ.prop) (P.e μ.val) 1 = P.e μ.val 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..4006f582a0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoBiprod.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 +-/ + +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. +-/ + +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 + show 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..33553d2fb5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoTwist.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 +-/ + +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. +-/ + +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..7dd4611ede --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RowColIdem.lean @@ -0,0 +1,704 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow +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. +-/ + +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 + show (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 + show (-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 + show newtonHZ (fun c => -t c) ((j : ℤ) - (i : ℤ)) = 0 + refine newtonHZ_neg _ _ ?_ + have : (j : ℕ) < (i : ℕ) := hij + omega + rw [Matrix.det_of_upperTriangular htri] + refine Finset.prod_eq_one fun i _ => ?_ + show 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 [if_neg (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, if_pos (by omega)] + · obtain ⟨l, hl⟩ : ∃ l, kk + 1 - ik = l + 1 := + ⟨kk - ik, by omega⟩ + rw [hl, newtonH_zero_fun, if_neg (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 _ + show _ = 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 + show 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 [if_neg (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_lowerTriangular _ 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 [if_pos (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 + show ((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..43311f9940 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichMerge.lean @@ -0,0 +1,152 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAssoc +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescent +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. +-/ + +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..61a8c73c18 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichRetract.lean @@ -0,0 +1,196 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTensor +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. +-/ + +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..030c093790 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichZig.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMultiTriple +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`. +-/ + +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 + show (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..c2915d87b4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarBraiding.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd +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. +-/ + +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, if_pos 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 [if_pos hs, hs] + norm_num + · have hs' : Equiv.Perm.sign σ = -1 := + (Int.units_eq_one_or _).resolve_left hs + rw [if_neg 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 σ * + (if Equiv.Perm.sign σ = 1 then (1 : ℂ) else c)) • + 𝟙 (tensorPow A X n) := by + classical + have hlift : permAlg X n x = + x.sum fun σ r => r • permMor X n σ := by + rw [permAlg] + exact MonoidAlgebra.lift_apply _ _ + rw [hlift] + rw [show (x.sum fun σ r => r • permMor X n σ) = + ∑ σ ∈ x.support, x σ • 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 + rw [Shape.e, 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) σ) = + (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) σ + = ∑ σ : 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) σ * + ((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) σ * + ((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) σ = + ((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) σ * + (if Equiv.Perm.sign σ = 1 then (1 : ℂ) else 1)) = + ∑ σ : Equiv.Perm (Fin lam.card), (P.e lam) σ from + Finset.sum_congr rfl fun σ _ => by rw [ite_self, mul_one]] + rw [sum_e_coeff, diagramSchur_superPS_row, + if_neg (by omega), mul_zero, zero_smul] + rfl + +/-- **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) σ * + (if Equiv.Perm.sign σ = 1 then (1 : ℂ) else -1)) = + ∑ σ : Equiv.Perm (Fin lam.card), (P.e lam) σ * + ((Equiv.Perm.sign σ : ℤ) : ℂ) from + Finset.sum_congr rfl fun σ _ => by + by_cases hs : Equiv.Perm.sign σ = 1 + · rw [if_pos hs, hs] + norm_num + · rw [if_neg hs, + (Int.units_eq_one_or _).resolve_left hs] + norm_num] + rw [sum_e_coeff_sign, diagramSchur_superPS_col, + if_neg (by omega), mul_zero, zero_smul] + rfl + +/-- 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..38924ae7a0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarLinear.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact +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. +-/ + +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 + show scalarSmul φ 1 f = f + rw [scalarSmul_eq, scalarEnd_one, Category.id_comp] + mul_smul a b f := by + show scalarSmul φ (a * b) f = scalarSmul φ a (scalarSmul φ b f) + rw [scalarSmul_eq, scalarSmul_eq, scalarSmul_eq, scalarEnd_mul, + Category.assoc] + smul_zero c := by + show scalarSmul φ c 0 = 0 + rw [scalarSmul_eq, Limits.comp_zero] + smul_add c f g := by + show 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 + show 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 + show 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 + show scalarSmul φ r f ≫ g = scalarSmul φ r (f ≫ g) + rw [scalarSmul_eq, scalarSmul_eq, Category.assoc] + comp_smul X Y Z f r g := by + show 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 + letI := linearOfScalarUnit φ + refine ⟨fun X {Y Z} r f => ?_, fun r {Y Z} f X => ?_⟩ + · show X ◁ scalarSmul φ r f = scalarSmul φ r (X ◁ f) + rw [scalarSmul_eq, scalarSmul_eq, + MonoidalCategory.whiskerLeft_comp, whiskerLeft_scalarEnd φ h] + · show 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 + haveI : Limits.HasFiniteBiproducts C := + Limits.HasFiniteBiproducts.of_hasFiniteCoproducts + haveI : Limits.HasBinaryBiproducts C := + Limits.hasBinaryBiproducts_of_finite_biproducts C + haveI : Limits.HasBinaryBiproducts (Ind C) := + Limits.hasBinaryBiproducts_of_finite_biproducts (Ind C) + haveI : (indOf (C := C)).PreservesZeroMorphisms := + Functor.preservesZeroMorphisms_of_map_zero_object + (isZero_indOf (Limits.isZero_zero C)).isoZero + haveI := 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 + haveI := 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..ffc13c97cf --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitEquiv.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 +-/ + +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. +-/ + +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 + show (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..3917f4e3ba --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitInd.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 +-/ + +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. +-/ + +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 + letI := linearOfScalarUnit φ + have hval : ∀ c : ℂ, (c • 𝟙 (𝟙_ D) : 𝟙_ D ⟶ 𝟙_ D) = + scalarHom φ c := by + intro c + show 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, ?_⟩ + show ((φ.symm f) • 𝟙 (𝟙_ D) : 𝟙_ D ⟶ 𝟙_ D) = f + rw [hval] + show (φ (φ.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..ce68677e36 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean @@ -0,0 +1,491 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear +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`. +-/ + +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 ?_ + dsimp [coyonedaDayCorepresentableBy] + rw [coyonedaEquiv_apply] + 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 + rw [(dayCoyonedaCorepresentableBy (𝟙_ D) a).homEquiv_comp, + (dayCoyonedaCorepresentableBy (𝟙_ D) a).homEquiv_comp, + dayCoyonedaCorepresentableBy_homEquiv_iso, + dayEvaluation_map_apply, dayEvaluation_map_apply, + dayCoyonedaCorepresentableBy_homEquiv_apply, + whiskerRight_dayUnitIso_inv_app_unitElt, + day_leftUnitor_hom_app_eta] + show 𝟙 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 + rw [← 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 + rw [← 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 + letI := linearOfScalarUnit (indScalarUnit ψ) + haveI := indOf_additive (C := C) + induction x using MonoidAlgebra.induction_on with + | hM σ => + rw [MonoidAlgebra.of_apply, permAlg_single, permAlg_single] + exact indOfPowIso_permMor X n σ + | hadd 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) + | hsmul 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 + letI := 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 + show 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] + rfl + +/-- `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..7208516037 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurVanishing.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 +-/ + +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. +-/ + +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..dae2d31bcf --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean @@ -0,0 +1,2495 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct +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. +-/ + +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 _ + rw [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 + simp only [chainStage2Cast_rfl, + MonoidalCategory.whiskerLeft_id, Category.id_comp] + exact (Category.comp_id _).symm + +/-- **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 + rw [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] + +/-- **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 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 + rw [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 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 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 _ + 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 + simp only [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 + simp only [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] + simp only [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 + simp only [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')] + +/-- **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 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 _ _ _ + 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 hD10 : (chainSeed A M M' d ▷ M.X) ≫ + (β_ (chainStage2 A M M' 0 0) M.X).hom = + (β_ (𝟙_ D) M.X).hom ≫ (M.X ◁ chainSeed A M M' d) := + BraidedCategory.braiding_naturality_left _ _ + have hD11 : (M.X ◁ chainSeed A M M' d) ≫ + ((ρ_ M.X).inv ▷ (chainStage2 A M M' 0 0)) = + ((ρ_ M.X).inv ▷ (𝟙_ D)) ≫ + ((M.X ⊗ (𝟙_ D)) ◁ chainSeed A M M' d) := + whisker_exchange _ _ + have hD12 : ((M.X ⊗ (𝟙_ D)) ◁ chainSeed A M M' d) ≫ + (α_ M.X (𝟙_ D) (chainStage2 A M M' 0 0)).hom = + (α_ M.X (𝟙_ D) (𝟙_ D)).hom ≫ + (M.X ◁ ((𝟙_ D) ◁ chainSeed A M M' d)) := + associator_naturality_right _ _ _ + 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))) := by + 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] + _ = (((ρ_ 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 + simp only [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] + simp only [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..cd671679f5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeAlgebra.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeFintype +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. +-/ + +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 Finsupp.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..818148bb85 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeFintype.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 +-/ + +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`". +-/ + +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..688496c177 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SignConj.lean @@ -0,0 +1,277 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoverFactor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow +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. +-/ + +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 + rw [← MonoidalCategory.id_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, + MonoidalCategory.tensorHom_comp_tensorHom, + Category.comp_id, Category.id_comp, modPowπ_perm] + rw [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 + rw [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] + rfl + -- 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] + show 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] + show (((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 = _ + rw [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..c469150dea --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleGenerator.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.GeneratorAlgebra +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. +-/ + +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 + letI := linearOfScalarUnit ψ + letI := monoidalLinearOfScalarUnitBraided ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + obtain ⟨p, q, 𝔸, hmon, hcomm, hne, hcp, ⟨e⟩⟩ := + exists_generator_algebra ψ P P₀ L X₀ lam hkill hlen + letI := hmon + letI := hcomm + obtain ⟨𝔹, hmon', hcomm', π, hne', hepi, hhom, hsimple⟩ := + exists_simple_quotient 𝔸 hne + letI := hmon' + letI := hcomm' + haveI := 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..252d51eb9e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimplePoint.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 +-/ + +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. +-/ + +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 + letI : 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..3a958a670f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleQuotient.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescentClose +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 +`⊤`. +-/ + +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 _ + show (⊥ : 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] + haveI : IsSplitEpi I.arrow := IsSplitEpi.mk' ⟨_, hs⟩ + haveI : 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 + haveI : Nonempty (SubIndex s) := ⟨equivShrink ↥s ⟨x, hx⟩⟩ + haveI : 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⟩, ?_, ?_⟩ + · show SubIndex.val j ≤ SubIndex.val _ + rw [SubIndex.val_index hz]; exact h₁ + · show 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 + haveI : 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 + haveI : ∀ j, Mono ((subCocone s).ι.app j) := fun j => + inferInstanceAs (Mono (SubIndex.val j).arrow) + haveI : Mono ((subCocone s).ι) := NatTrans.mono_of_mono_app _ + haveI : 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 + rw [← 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] + infer_instance + +/-! ## 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 + haveI := 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)) + haveI : 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 + haveI : 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 + haveI : 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 + haveI : 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 + letI : MonObj (cokernel 𝔪.arrow) := quotMonObj 𝔸 𝔪 hid + have hmul : (cokernel.π 𝔪.arrow ⊗ₘ cokernel.π 𝔪.arrow) ≫ + μ[cokernel 𝔪.arrow] = μ[𝔸] ≫ cokernel.π 𝔪.arrow := + tensorHom_π_quotMul 𝔸 𝔪 hid + letI : IsCommMonObj (cokernel 𝔪.arrow) := + isCommMonObj_of_epi (cokernel.π 𝔪.arrow) hmul + haveI : 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] + haveI : 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..3bd3a65207 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleScalars.lean @@ -0,0 +1,357 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient +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`). +-/ + +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 + show 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 + haveI : 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 + haveI : IsIso (Subobject.mk (image.ι k)).arrow := + (Subobject.isIso_arrow_iff_eq_top _).2 h + haveI : 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) + haveI : 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 + · haveI : 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 + haveI : 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 + haveI := 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 + · haveI := epi_of_imageSubobject_eq_top h + haveI : 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..39895f231c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean @@ -0,0 +1,631 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSummand +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffleLine +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. +-/ + +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 + haveI := 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] + haveI : 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] + haveI : 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₀ + · haveI : 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 + haveI := 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 + haveI : 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 + haveI := h + exact inferInstanceAs (IsIso ((Mod.forget (D := Ind C) 𝔹).map f)) + · intro h + haveI := h + haveI : Mono f := (mono_iff_hom 𝔹 f).2 inferInstance + haveI : 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 _) + show (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 + haveI := hg + haveI hmono : Mono g.hom := (mono_iff_hom 𝔹 g).1 hg + constructor + · intro hiso h0 + haveI := 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 + · haveI : 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 + haveI := h + haveI : 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 := 𝔹) μ[𝔹] + show ((α_ 𝔹 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 _ _ ?_ + show (g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom = 0 + rw [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 + haveI := simple_regularMod 𝔹 hsimple hne + constructor + intro M g hg + haveI := hg + haveI hgm : Mono g.hom := (mono_iff_hom 𝔹 g).1 hg + haveI hwm : Mono (g.hom ▷ L.obj) := + inferInstanceAs (Mono ((tensorRight L.obj).map g.hom)) + haveI hhm : Mono (lineToRegular 𝔹 L g) := by + refine mono_of_mono_hom _ ?_ + show Mono ((g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom) + infer_instance + constructor + · intro hiso h0 + haveI := 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 + haveI : IsIso (lineToRegular 𝔹 L g) := + isIso_of_mono_of_nonzero + (fun h => h0 ((lineToRegular_eq_zero_iff 𝔹 L g).1 h)) + haveI : IsIso ((g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom) := + (isIso_iff_hom 𝔹 (lineToRegular 𝔹 L g)).1 inferInstance + haveI : IsIso (g.hom ▷ L.obj) := + IsIso.of_isIso_comp_right _ (L.rot 𝔹).hom + 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 + haveI := hf + refine mono_of_mono_hom _ ?_ + show 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 + haveI := hf + refine epi_of_epi_hom _ ?_ + show 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 + haveI := simple_regularMod 𝔹 hsimple hne + haveI := simple_freeMod_oddLine 𝔹 L hsimple hne + haveI := 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 + haveI := simple_regularMod 𝔹 hsimple hne + haveI := simple_freeMod_oddLine 𝔹 L hsimple hne + haveI := 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 + haveI := simple_regularMod 𝔹 hsimple hne + haveI := simple_freeMod_oddLine 𝔹 L hsimple hne + haveI := 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 + haveI := 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..fbb0169b64 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SmallReduction.lean @@ -0,0 +1,453 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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 + show G.map ((hG.preimage (r • G.map f)) ≫ g) = _ + rw [Functor.map_comp, hG.map_preimage] + show _ = 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 + show G.map (f ≫ (hG.preimage (r • G.map g))) = _ + rw [Functor.map_comp, hG.map_preimage] + show _ = 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. -/ +@[implicit_reducible] +def 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 + haveI := hi + haveI := 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 + haveI := hi + haveI := 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.Additive] [G.Linear ℂ] + [G.Monoidal] (h : HasScalarUnit A) : HasScalarUnit B := by + have h' : Function.Bijective + (fun c : ℂ => (c • 𝟙 (𝟙_ A) : 𝟙_ A ⟶ 𝟙_ A)) := h + show 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. -/ +@[implicit_reducible] +def 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. -/ +@[implicit_reducible] +def 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. -/ +@[implicit_reducible] +def 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. -/ +@[implicit_reducible] +def 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. -/ +@[implicit_reducible] +def 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. -/ +@[implicit_reducible] +def 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. -/ +@[implicit_reducible] +def 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. -/ +@[implicit_reducible] +def 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..606d46a5c1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAdjoint.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 +-/ + +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. +-/ + +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..9675dc7f4a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.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 +-/ + +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. +-/ + +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 + rw [chainBGrUnit, ← Category.assoc, + chainBUnit_chainBGrComponentZeroIso_inv, Category.assoc] + exact h1.trans h2.symm + +section Linear + +-- Raised budget: 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 + show 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 _ _ _ + +-- Raised budget: linearity of the insertion unfolds the module +-- action through the duality datum on one generator. +/-- **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 + show 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 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 _ + 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..17aef2b1a9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitClosure.lean @@ -0,0 +1,427 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreRestrict +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. +-/ + +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 + haveI : (indOf (C := C)).Additive := indOf_additive + intro Y + obtain ⟨k, ab, hsq⟩ := hgen Y + show 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..7174a5f58e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitComplement.lean @@ -0,0 +1,739 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtract +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. +-/ + +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 + letI := 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 + letI := 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 + rw [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' + · rw [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] + · rw [biprod.inr_desc_assoc, Category.comp_id] + apply biprod.hom_ext + · rw [Category.assoc, biprod.lift_fst, biprod.inr_fst] + haveI : 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 ?_ + rw [Limits.zero_comp, Category.assoc] + exact kernel.condition _ + · rw [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δ)) ?_ + 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 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 + show 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 + show 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..60e6cb0edb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitEverything.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleGenerator +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimplePoint +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitClosure +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfLinear +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleSplit +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. +-/ + +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 + letI := linearOfScalarUnit ψ + letI := monoidalLinearOfScalarUnitBraided ψ + letI := linearOfScalarUnit (indScalarUnit ψ) + letI := 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 + letI := hmonA + letI := hcommA + letI := hmon + letI := hcomm + haveI := 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 + haveI : (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..d66de09c42 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExact.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive +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. +-/ + +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..285df30b40 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtract.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 +-/ + +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. +-/ + +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 + letI := 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δ + show ((ρ_ 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..d79bf17a6a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtractDual.lean @@ -0,0 +1,879 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + letI := 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δ + show ((ρ_ 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 + letI := 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 + letI := 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 + rw [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' + · rw [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] + · rw [biprod.inr_desc_assoc, Category.comp_id] + apply biprod.hom_ext + · rw [Category.assoc, biprod.lift_fst, biprod.inr_fst] + haveI : 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 ?_ + rw [Limits.zero_comp, Category.assoc] + exact kernel.condition _ + · rw [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δ)) ?_ + 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 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..8a36c86c83 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.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 +-/ + +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. +-/ + +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 + rw [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) + +-- Raised budget: 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 + show μ[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..771519b53d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitPairDef.lean @@ -0,0 +1,175 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAssemble +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. +-/ + +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 _ _ _ + +-- Raised budget: 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 + show 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 + show 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..d2fba3672c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitReduce.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 +-/ + +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. +-/ + +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..666a793d77 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitTransport.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedTransport +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. +-/ + +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 + rw [← 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'] + show (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..2647e6285f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplittingAlgebra.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UniversalAlgebra +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. +-/ + +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..c4c5c11c5b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StateTransport.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State +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. +-/ + +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..0f18ea0cee --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepA.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaClose +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAdjoint +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. +-/ + +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 + letI := st.monObj + letI := st.comm + obtain ⟨sd⟩ := keyLemmaData_ind st.base st.rest st.restDual + st.datum st.zigzag st.unit_ne_zero hSym + letI := sd.monObj + letI := sd.comm + letI := 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..f5887f9a8f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepATransport.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeFree +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. +-/ + +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 + show 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 + show 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..d3aa97c3cf --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepB.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepA +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistState +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. +-/ + +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 + letI := st.monObj + letI := 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..fc3deb7c31 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed.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 +-/ + +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..b2b2e1c787 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Letters.lean @@ -0,0 +1,1399 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show (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 + show (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 + show 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 + show 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 + show 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 + show 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 + show 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 σ * 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 σ • permMor X n σ + := by + classical + have hlift : permAlg X n x = + x.sum fun σ r => r • permMor X n σ := by + rw [permAlg] + exact MonoidAlgebra.lift_apply _ _ + rw [hlift, show (x.sum fun σ r => r • permMor X n σ) = + ∑ σ ∈ x.support, x σ • permMor X n σ from rfl] + refine Finset.sum_subset (Finset.subset_univ _) fun σ _ hσ => ?_ + rw [Finsupp.notMem_support_iff.mp hσ, zero_smul] + rfl + +/-- 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 σ * 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 [dif_pos hpop, colourSum, Finset.sum_filter, + Finset.sum_smul] + refine Finset.sum_congr rfl fun σ _ => ?_ + by_cases hσ : permIndex σ c = d + · rw [if_pos hσ, Linear.smul_comp, Category.assoc, + S.nIn_nOut_of_eq hσ, eqToHom_trans] + · rw [if_neg hσ, Linear.smul_comp, Category.assoc, + S.nIn_nOut_ne n hσ, Limits.comp_zero, smul_zero, zero_smul] + · rw [dif_neg 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, dif_pos 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 [dif_pos hpop, hx c d, zero_smul, Limits.zero_comp, + Limits.comp_zero] + · rw [dif_neg 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..9195df9f1a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Signs.lean @@ -0,0 +1,422 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarBraiding +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. +-/ + +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] + show 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 ?_ + show 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 ?_ + show 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 ?_ + show 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 [if_pos 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 [if_neg 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..02ba9401b1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean @@ -0,0 +1,892 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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 => + rw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_last, + Fin.lastCases_last] + exact biprod.inr_snd + | cast j => + rw [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' => + rw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_last, + Fin.lastCases_castSucc] + exact inr_miss _ + | cast j => + induction i' using Fin.lastCases with + | last => + rw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_castSucc, + Fin.lastCases_last] + exact inl_miss _ + | cast j' => + rw [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 => + show (∑ 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 + rw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_castSucc, + Fin.lastCases_castSucc]] + rw [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 => + show (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 => + show (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' => + show (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' => + show (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' => + show (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' => + show (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] + show (∑ 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 + · show 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 + · show 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 + · show 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 + · show 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 + · show 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 + · show 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 + · show 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 + · show 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 + · show 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 + · show 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 + · show 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 + · show 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.induction_on with + | zero => simp + | 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⟩ + show ((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⟩ + show ((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 + · show (LinearMap.proj (R := ℂ) (φ := fun _ : Fin (p + 1) => ℂ) + i).comp (LinearMap.single ℂ (fun _ => ℂ) i) = + LinearMap.id + refine LinearMap.ext fun z => ?_ + show 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 → ℂ) _ _ + · show (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 + show 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 + · show (LinearMap.proj (R := ℂ) (φ := fun _ : Fin (p + 1) => ℂ) + i').comp (LinearMap.single ℂ (fun _ => ℂ) i) = 0 + refine LinearMap.ext fun z => ?_ + show 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 => ?_ + show (LinearMap.pi fun _ : Fin 1 => + LinearMap.proj (R := ℂ) + (φ := fun _ : Fin (q + 1) => ℂ) j') + ((0 : PUnit →ₗ[ℂ] (Fin (q + 1) → ℂ)) z) = 0 + rw [LinearMap.zero_apply, map_zero] + | inr j => + cases k' with + | inl i' => + apply SuperVect.hom_ext + · refine LinearMap.ext fun z => ?_ + show (LinearMap.proj (R := ℂ) + (φ := fun _ : Fin (p + 1) => ℂ) i') + ((0 : (Fin 0 → ℂ) →ₗ[ℂ] (Fin (p + 1) → ℂ)) z) = 0 + rw [LinearMap.zero_apply, map_zero] + · 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 → ℂ) _ _ + · show (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 + show 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 := 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..4ab1760b91 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEvenRing.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.NullPoint +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). +-/ + +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 + show 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 + show 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 + show 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..164c0b1911 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGamma.lean @@ -0,0 +1,391 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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 + show convAlong R (λ_ (𝟙_ D)).inv η x = x + exact convAlong_one_left R x + one_mul_o := fun u => by + show convAlong R (λ_ o).inv η u = u + exact convAlong_one_left R u + assoc_eee := fun x y z => by + show 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 + show 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 + show 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 + show 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 + show 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 + show 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 + show 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 + show 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 + show 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 + show 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 + show 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..a8e7fdee4a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean @@ -0,0 +1,766 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGamma +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed +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`. +-/ + +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. -/ +private 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. -/ +private 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 := + 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 + show (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 _ _ + · show 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. -/ +private 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 + show (c • (LinearMap.id : ℂ →ₗ[ℂ] ℂ)) 1 = c + simp + right_inv f := by + apply SuperVect.hom_ext + · show (unitEvenMap f 1) • (LinearMap.id : ℂ →ₗ[ℂ] ℂ) = + unitEvenMap f + refine LinearMap.ext fun z => ?_ + calc (unitEvenMap f 1 • (LinearMap.id : ℂ →ₗ[ℂ] ℂ)) z + = z • unitEvenMap f 1 := by + show 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 + · show (a * b) • (LinearMap.id : ℂ →ₗ[ℂ] ℂ) = + (a • (LinearMap.id : ℂ →ₗ[ℂ] ℂ)) ∘ₗ + (b • (LinearMap.id : ℂ →ₗ[ℂ] ℂ)) + refine LinearMap.ext fun z => ?_ + show (a * b) * z = a * (b * z) + rw [mul_assoc] + · exact Subsingleton.elim _ _ + map_add' a b := by + apply SuperVect.hom_ext + · show (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 ?_ + show (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 + +/-- **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..88898c8211 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModAbelian.lean @@ -0,0 +1,701 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + map_smul' c a := by + refine LinearMap.ext fun e => Subtype.ext ?_ + simp + +@[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 + show 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..6166697ad0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprod.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 +-/ + +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. +-/ + +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..648ff1d52c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprodMap.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod +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. +-/ + +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 + show (e.hom ≫ e.inv).evenMap m = m + rw [e.hom_inv_id] + rfl + · intro n + show (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 + show (e.hom ≫ e.inv).oddMap m = m + rw [e.hom_inv_id] + rfl + · intro n + show (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..6e1898e94a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModHom.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 +-/ + +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. +-/ + +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 + show g.evenMap (f.evenMap _) = _ + rw [f.map_actEE, g.map_actEE] + rfl + map_actEO x m := by + show g.oddMap (f.oddMap _) = _ + rw [f.map_actEO, g.map_actEO] + rfl + map_actOE u m := by + show g.oddMap (f.oddMap _) = _ + rw [f.map_actOE, g.map_actOE] + rfl + map_actOO u m := by + show 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 => ?_) + · show g.evenMap (f.evenMap x + f'.evenMap x) = _ + exact map_add _ _ _ + · show 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..21ae03106c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModIso.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 +-/ + +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. +-/ + +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..9964ebef47 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModMonoidal.lean @@ -0,0 +1,2441 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod +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. +-/ + +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 => ?_) + · show (leftUnitorHom M).evenMap (tmulEE S.unitMod M S.one m) = m + rw [leftUnitorHom_evenMap_tmulEE] + exact M.one_act_e m + · show (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 => ?_) + · show (rightUnitorHom M).evenMap + (tmulEE M S.unitMod m S.one) = m + rw [rightUnitorHom_evenMap_tmulEE] + exact M.one_act_e m + · show (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..59f6b3a6e4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShift.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 +-/ + +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. +-/ + +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..fef1ef3880 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShiftUnit.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal +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. +-/ + +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 + show M.actOE (S.mulEO b m) n = M.actOE m (M.actEE b n) + rw [← M.assoc_oee, ← S.comm_eo] + hoo := fun b m n => by + show -M.actEO (S.mulEE b m) n = -M.actEO m (M.actEO b n) + rw [M.assoc_eeo, M.actEO_actEO_comm] + hoeo := fun c m n => by + show -M.actEO (S.mulOO c m) n = M.actOE m (M.actOO c n) + rw [M.assoc_ooo, M.actOE_actOO_neg, neg_neg] + hooe := fun c m n => by + show M.actOE (S.mulOE c m) n + = -(-(M.actEO m (M.actOE c n))) + rw [neg_neg, M.assoc_oee, M.actEO_actOE] + heeo := fun b m n => by + show -M.actOO (S.mulEO b m) n = -M.actOO m (M.actEO b n) + rw [M.assoc_eoo, M.actEE_actOO] + heoe := fun b m n => by + show M.actEE (S.mulEE b m) n = M.actEE m (M.actEE b n) + rw [M.assoc_eee, M.actEE_actEE_comm] + hoee := fun c m n => by + show M.actEE (S.mulOO c m) n = -(M.actOO m (M.actOE c n)) + rw [M.assoc_ooe, M.actOO_actOE_neg] + hooo := fun c m n => by + show -M.actOO (S.mulOE c m) n = -(M.actEE m (M.actOO c n)) + rw [M.assoc_oeo, M.actEE_actOO] + aee := fun a m n => M.assoc_eoe a m n + aoo := fun a m n => by + show -M.actEO (S.mulEE a m) n = M.actEO a (-(M.actEO m n)) + rw [M.assoc_eeo, map_neg] + aeo := fun a m n => by + show -M.actOO (S.mulEO a m) n = M.actEE a (-(M.actOO m n)) + rw [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 + show -M.actOO (S.mulOE c m) n = M.actOO c (-(M.actEO m n)) + rw [M.assoc_oeo, map_neg] + ceo := fun c m n => by + show -M.actEO (S.mulOO c m) n = M.actOE c (-(M.actOO m n)) + rw [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 + show -(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)) + rw [map_neg, actEE_tmulOO, tmulOO_balanced_eoo] + map_actEO x m := by + show 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) + rw [actEO_tmulOE, tmulOE_balanced_eoe] + map_actOE v m := by + show 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, actOE_tmulOO, tmulEO_balanced_ooo, neg_neg] + map_actOO v m := by + show -(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) + rw [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 => ?_) + · rw [comp_evenMap, LinearMap.comp_apply, + shiftUnitHom_evenMap_tmulEE, shiftUnitInv_evenMap, + id_evenMap, LinearMap.id_coe, id_eq, + ← tmulEE_balanced_ooe, shiftUnitMod_actOO_one] + · rw [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] + · rw [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] + · rw [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 => ?_) + · show (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..f62f945152 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModTensor.lean @@ -0,0 +1,1141 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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 + show 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 + show 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 + show 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 + show 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 + show 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 + show 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 + show 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 + show 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..dc9f6f29ec --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperPointMod.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEvenRing +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. +-/ + +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 _ _ ?_ + show 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 _ _ ?_ + show 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 _ _ ?_ + show (0 : ℂ) = P.chi x * (0 : ULift.{w} ℂ).down + simp + assoc_oee _ _ _ := Subsingleton.elim _ _ + assoc_oeo x u m := by + refine ULift.ext _ _ ?_ + show (0 : ℂ) = (0 : ULift.{w} ℂ).down + rfl + assoc_ooe u v m := by + refine ULift.ext _ _ ?_ + show 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..4acdabf22e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.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 +-/ + +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`. +-/ + +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. +@[nolint checkUnivs] +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 + show 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 + show 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 + show 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 + · show g.evenMap ∘ₗ (f.evenMap + f'.evenMap) = _ + exact LinearMap.comp_add _ _ _ + · show g.oddMap ∘ₗ (f.oddMap + f'.oddMap) = _ + exact LinearMap.comp_add _ _ _ + comp_add _ _ _ f g g' := by + apply Hom.ext + · show (g.evenMap + g'.evenMap) ∘ₗ f.evenMap = _ + exact LinearMap.add_comp _ _ _ + · show (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 + · show g.evenMap ∘ₗ (c • f.evenMap) = _ + exact LinearMap.comp_smul _ _ _ + · show g.oddMap ∘ₗ (c • f.oddMap) = _ + exact LinearMap.comp_smul _ _ _ + comp_smul _ _ _ f c g := by + apply Hom.ext + · show (c • g.evenMap) ∘ₗ f.evenMap = _ + exact LinearMap.smul_comp _ _ _ + · show (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 + haveI : (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 + haveI : 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 + haveI : 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 + haveI : 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)) + · haveI : Subsingleton + (((Ind.inclusion C).obj (indOf.obj (0 : C))).obj Y) := + hsub0 Y.unop + haveI : 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 [unitHomMul, tensorHom_def] + 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..3186109a2e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSeries.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums +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. +-/ + +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, + if_neg (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) * d⁄dX ℂ ((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 : d⁄dX ℂ (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) * d⁄dX ℂ ((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 : d⁄dX ℂ ((1 - X) ^ p * newtonHSeries (superPS p q)) = + (1 - X) ^ p * + (powerSumSeries (superPS p q) * newtonHSeries (superPS p q)) + + newtonHSeries (superPS p q) * d⁄dX ℂ ((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) * d⁄dX ℂ 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 * d⁄dX ℂ 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..ad6399271c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSmall.lean @@ -0,0 +1,619 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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 [dif_pos rfl, eqToHom_refl] + refine hom_ext (LinearMap.ext fun x => ?_) + (LinearMap.ext fun x => ?_) + · show 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 + · show 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 [dif_neg hne] + refine hom_ext (LinearMap.ext fun x => ?_) + (LinearMap.ext fun x => ?_) + · show 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 + · show 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 + show 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 _ _) + show 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 + show 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 => ?_) + show 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 => ?_ + show 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 => ?_ + show 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 [dif_pos rfl, eqToHom_refl] + exact InducedCategory.hom_ext + (SuperVect.evenLineIn_comp_prj_same p q i) + · rw [dif_neg fun h => hne (Sum.inl.inj h)] + refine InducedCategory.hom_ext ?_ + rw [smallZero_hom] + exact SuperVect.evenLineIn_comp_prj_ne p q hne + · rw [dif_neg (Sum.inl_ne_inr)] + refine InducedCategory.hom_ext ?_ + rw [smallZero_hom] + exact SuperVect.evenLineIn_comp_oddPrj p q i j' + · rw [dif_neg (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 [dif_pos rfl, eqToHom_refl] + exact InducedCategory.hom_ext + (SuperVect.oddLineIn_comp_prj_same p q j) + · rw [dif_neg 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), ?_⟩ + haveI : 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..5210a8299f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperValues.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplit +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. +-/ + +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..620100c093 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean @@ -0,0 +1,1258 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing +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. +-/ + +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 + show 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 => + show ((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 => + show ((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, LinearEquiv.prodCongr_apply, + TensorProduct.prodLeft_tmul, TensorProduct.prodRight_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 + show 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] + show 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.induction_on with + | zero => simp + | add a b ha hb => simp only [TensorProduct.add_tmul, map_add, ha, hb] + | tmul x y => + show 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] + show (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] + show ((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 + simp only [LinearMap.fst_apply, LinearMap.snd_apply] + 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] + show 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] + show (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] + show (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.induction_on with + | zero => simp + | 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.induction_on with + | zero => simp + | 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 + letI : AddCommGroup M := Module.addCommMonoidToAddCommGroup ℂ + letI : AddCommGroup N := Module.addCommMonoidToAddCommGroup ℂ + exact LinearMap.trace_comp_comm' f g + +-- Raised budget: the supertrace is conjugated through the +-- braiding on each of the four parity blocks. +/-- **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 + show 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 => ?_ + show 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 + show 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 + show 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 => ?_ + show 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 => ?_ + show (tot h ((x.1, 0) : Tot X)) + + tot (parHom X) (tot h ((0, x.2) : Tot X)) = tot k x + rw [hk] + show ((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 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'] + 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 + rw [show insertTop X 0 0 = 𝟙 _ from insertTop_zero X 0, + Category.id_comp] + show 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 ℂ] + haveI : 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] + show 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] + letI : 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 _ + show 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 ℂ] + haveI : 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 π + show 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 + show 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 + | hM σ => + show (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 + | hadd 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 + | hsmul 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..6fdd1c994a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymAlg.lean @@ -0,0 +1,1969 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor +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. +-/ + +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, whiskerRightIso_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] + rw [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] + rw [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] + rw [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 ⊢ + exact 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 ⊢ + 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 ⊢ + exact 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 ⊢ + 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..8f8ffa7668 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymDatum.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 +-/ + +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. +-/ + +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 + letI := modTensorModObj A Q' Q + letI := modTensorModObj A P' P + have hp : modTensorAct A P' P ≫ d.pair = + (A ◁ d.pair) ≫ μ[A] := d.pair_linear + show 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 + letI := modTensorModObj A Q Q' + letI := modTensorModObj A P P' + have hc : μ[A] ≫ d.copair = + (A ◁ d.copair) ≫ modTensorAct A P P' := d.copair_linear + show μ[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..09b3638946 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean @@ -0,0 +1,1709 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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] + show ((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] + simp only [Category.assoc] at hstep ⊢ + 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 ⊢ + rw [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] + show (ρ_ (𝟙_ 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] + show (α_ (𝟙_ 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 ⊢ + 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 ⊢ + 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)) + (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 + | hM σ => + induction y using MonoidAlgebra.induction_on with + | hM τ => + 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 σ τ + | hadd y₁ y₂ hy₁ hy₂ => + rw [blockAlgEmbed_add_snd, map_add, map_add] + exact tensor_add_glue hy₁ hy₂ + | hsmul r y' hy => + rw [blockAlgEmbed_smul_snd, map_smul, map_smul] + exact tensor_smul_glue r hy + | hadd x₁ x₂ hx₁ hx₂ => + rw [blockAlgEmbed_add_fst, map_add, map_add] + exact add_tensor_glue hx₁ hx₂ + | hsmul 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 σ _ => ?_ + show 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 + letI : Unique (Equiv.Perm (Fin 0)) := + ⟨⟨1⟩, fun σ => Equiv.ext fun x => x.elim0⟩ + rw [symmetriser, Fintype.sum_unique] + show ((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 + letI : Unique (Equiv.Perm (Fin 1)) := + ⟨⟨1⟩, fun σ => Equiv.ext fun x => Subsingleton.elim _ _⟩ + rw [symmetriser, Fintype.sum_unique] + show ((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 + show ((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] + show ((λ_ 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] + show (β_ (𝟙_ 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τ] + simp only [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] + simp only [Category.assoc] + rw [reassoc_of% (comm_head X m n), hw] + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorDatum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorDatum.lean new file mode 100644 index 0000000000..9363a3b7a5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorDatum.lean @@ -0,0 +1,233 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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] + show ((β_ (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] + show (α_ 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..a5cb68cc84 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorExact.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 +-/ + +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). +-/ + +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..59e7e46f0f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorMuBraid.lean @@ -0,0 +1,129 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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..267aa98116 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorPowZero.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +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. +-/ + +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..22e0f496e5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorTransfer.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodTransfer +import LeanPool.RegtsSevenster.RS.Classical.Deligne.KronKill +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). +-/ + +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 + show 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 + show 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 + show 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 σ => ?_ + show 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 + show 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 σ => ?_ + show 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 + show 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 τ => ?_ + show 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 + show 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 + rw [Shape.e, 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] + rfl + · 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] + rfl + -- 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..76ad7d131a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorZigzag.lean @@ -0,0 +1,989 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.MuInterchange +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZagAction +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. +-/ + +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] + show η[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 + rw [← 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] + +/-- **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 => rw [← 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 => rw [comp_whiskerRight, comp_whiskerRight, + Category.assoc, Category.assoc, hzdef] + -- The inner contraction word, fully reduced at the fold. + 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]) + rw [← Category.assoc, tensorHom_π_interchange, + rawInterchangeπ, rawInterchange, Category.assoc, + Category.assoc] + exact congrArg (fun t : (N₁'.X ⊗ N₁.X) ⊗ (N₂'.X ⊗ N₂.X) ⟶ + A => tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ t) htail + conv_lhs => rw [hinner] + conv_lhs => rw [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 => rw [← 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 + show (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 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₂) + 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 => rw [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 => rw [MonoidalCategory.whiskerLeft_comp, + MonoidalCategory.whiskerLeft_comp, + 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 => rw [← 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 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]) + rw [← Category.assoc, tensorHom_π_interchange, + rawInterchangeπ, rawInterchange, Category.assoc, + Category.assoc] + exact congrArg (fun t : (N₁'.X ⊗ N₁.X) ⊗ (N₂'.X ⊗ N₂.X) ⟶ + A => tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ t) htail + conv_lhs => rw [← 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 + show ((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 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₂') + 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 + rw [← 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] + rw [← 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 + rw [← 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] + rw [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..53ed892ec9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TrichotomyClose.lean @@ -0,0 +1,175 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchur +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. +-/ + +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 + letI := st.monObj + letI := 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..c2dc2b4195 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistBiprod.lean @@ -0,0 +1,294 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +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. +-/ + +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 + letI := 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 + letI := 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 + haveI : 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..658ab9fe97 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistCoherence.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 +-/ + +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. +-/ + +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..31df662b44 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistDatum.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitFreeMod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistFreeTensor +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransferIso +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorZigzag +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTransport +import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing +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. +-/ + +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..e140fcca7f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistFreeTensor.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract +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. +-/ + +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 + letI := ModObj.regular A + show ((α_ 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 + letI := ModObj.regular A + show ((α_ 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 + letI := ModObj.regular A + show 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..e9c4fddfc8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistMixLine.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 +-/ + +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. +-/ + +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..21f2091033 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistPow.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSuccMod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZigzag +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. +-/ + +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..bac8fbc961 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistShuffle.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorDatum +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. +-/ + +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] + show ((β_ (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] + rw [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 + simpa only [MonoidalCategory.comp_whiskerRight, + MonoidalCategory.whiskerLeft_comp, Category.assoc] + using 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] + show (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) + rw [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 + rw [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 + letI := 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] + show (α_ 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 + letI := modTensorModObj A R S + haveI : 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 + show 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 + show 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 + show (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 + show (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 + show (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 + show (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..39d7b1e2d5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistState.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistDatum +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistBiprod +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistMixLine +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. +-/ + +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..2da71b8d82 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistSymPow.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SignConj +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. +-/ + +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..c63c19ab25 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistUnitor.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle +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. +-/ + +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 + show 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 + show 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 + show 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 + show 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 + letI := 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 + show ((α_ 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 + show ((α_ 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 + show 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..6f111f3c1f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitBase.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 +-/ + +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. +-/ + +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 + show ((α_ (𝟙_ 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 + show (λ_ 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 + show (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 + show (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..678a8e0158 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitFreeMod.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 +-/ + +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`. +-/ + +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..f83e7cca8a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitMod.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 +-/ + +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. +-/ + +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..644b69d987 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitSimple.lean @@ -0,0 +1,453 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + haveI := tensorLeft_preservesMono (A := A) (cokernel i) + haveI := tensorRight_preservesEpi (A := A) U + haveI : Mono (cokernel i ◁ i) := + Functor.map_mono (tensorLeft (cokernel i)) i + haveI : 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 + haveI := tensorRight_preservesMono (A := A) (cokernel i) + haveI := tensorLeft_preservesEpi (A := A) U + haveI : Mono (i ▷ cokernel i) := + Functor.map_mono (tensorRight (cokernel i)) i + haveI : 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 + haveI := tensorRight_preservesMono (A := A) U + haveI : 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 + haveI : 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 + haveI : IsSplitEpi + ((tensorLeft (cokernel i)).map (kernel.ι (unitMate i))) := + IsSplitEpi.mk' ⟨l, hl⟩ + haveI := tensorLeft_preservesMono (A := A) (cokernel i) + haveI : 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 + haveI := ht + haveI := tensorRight_preservesMono (A := A) (cokernel i) + haveI : 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) + haveI : 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 + haveI : Mono (T ◁ cokernel.π i) := + Preadditive.mono_of_isZero_kernel' _ hlim hT + haveI := tensorLeft_preservesEpi (A := A) T + haveI : Epi (T ◁ cokernel.π i) := + Functor.map_epi (tensorLeft T) (cokernel.π i) + haveI : 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] [MonoidalLinear ℂ A] + [RigidCategory A] (hu : HasScalarUnit A) : + Simple (𝟙_ A) := by + constructor + intro U i hi + haveI := hi + constructor + · -- an isomorphism into the unit is nonzero + intro hIso h0 + haveI := 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 + haveI : IsIso (cokernel i ◁ kernel.ι (unitMate i)) := + isIso_whiskerLeft_kernelMate i + haveI := tensorRight_preservesEpi (A := A) (kernel (unitMate i)) + haveI : 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] + haveI : 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 + haveI : Mono (j ≫ i) := by rw [hj]; exact mono_comp _ _ + haveI := tensorRight_preservesMono (A := A) U + haveI : 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 + haveI : Mono (kernel.ι (unitMate i) ≫ cokernel.π i) := + Abelian.mono_of_kernel_ι_eq_zero _ (hK.eq_zero_of_src _) + haveI : 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 + haveI : 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..58d0bc6ab0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitStage.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 +-/ + +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. +-/ + +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..beb1e9f7c6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UniversalAlgebra.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.CommonAlgebra +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. +-/ + +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 + letI : ∀ i : J ⊕ K, MonObj (Sum.elim Am Bs i) := fun i => + match i with + | Sum.inl j => Amon j + | Sum.inr k => Bmon k + letI : ∀ 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) + haveI : 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) + haveI : 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..7f7aeb3c4f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/WhiskerFaithful.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact +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. +-/ + +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 + haveI := 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 + haveI : Epi ev' := epi_of_nonzero_to_simple hne + haveI : Epi (P ◁ ev') := by + have heq : (tensorLeft P).map ev' = P ◁ ev' := rfl + haveI : (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] + haveI := 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..2cb39f9374 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/WordMap.lean @@ -0,0 +1,932 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show (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 => + show 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 _ + show ((ρ_ (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 ?_ + rw [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 + rw [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 + rw [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] + simp only [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..1ed63f1b36 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZagAction.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.BraidCoherence +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. +-/ + +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..c197c54f5e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagCarrier.lean @@ -0,0 +1,921 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show (modMultiTriv A (modSlots_singleton A X)).inv ≫ + (modMultiTriv A (modSlots_singleton A X)).hom ≫ + (ρ_ X.X).hom = (ρ_ X.X).hom + rw [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 + simp only [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 + simp only [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] + simp only [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 + simp only [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] + simp only [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] + simp only [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 + simp only [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] + simp only [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..ecb291db12 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagNonzero.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 +-/ + +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. +-/ + +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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagSandwich.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagSandwich.lean new file mode 100644 index 0000000000..79004d02a7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagSandwich.lean @@ -0,0 +1,307 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract +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. +-/ + +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] + simp only [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) + show (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 + show (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] + simp only [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) + show (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 + show (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..20ec3cacfa --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransfer.lean @@ -0,0 +1,368 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier +import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymDatum +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. +-/ + +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 + haveI := 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..f89f255b29 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransferIso.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 +-/ + +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. +-/ + +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..292ab9e975 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneBridge.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.FibreTransport +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. +-/ + +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 + show (β_ (ω.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 + letI 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..e98ebcfc9c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackage.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 +-/ + +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`. +-/ + +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..1e8bc56554 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackageRestrict.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 +-/ + +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. +-/ + +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..2d080c83cc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneTheorem.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage +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. +-/ + +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..daf3d7780e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/EulerianIndependence.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 +-/ + +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. +-/ + +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, dif_pos 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, + dif_neg hne, dif_neg 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 [dif_pos hc, dif_pos (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 [dif_neg hc, dif_neg (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..301d56b58b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/FibreTransport.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 +-/ + +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`. +-/ + +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..284b3916e6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/KoszulAction.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 +-/ + +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. +-/ + +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 + letI := P.additive + letI := P.linear + intro h + show (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..d6f1e196f7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaPerm.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.FibreTransport +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower +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. +-/ + +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 + letI := P.additive + letI := 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..a77065ee94 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaTensorPower.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaPerm +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`. +-/ + +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 + letI := P.braided + show (η P.ω ≫ ε P.ω : P.ω.obj (SkeinObj.mk 0) ⟶ _) = 𝟙 _ + exact Functor.Monoidal.η_ε P.ω + | n + 1 => by + letI := P.braided + show (δ 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 + letI := P.braided + show (ε P.ω ≫ η P.ω : SuperVect.tensorUnit ⟶ _) = 𝟙 _ + exact Functor.Monoidal.ε_η P.ω + | n + 1 => by + letI := P.braided + show ((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] [Preadditive 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 + show 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 + show 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 + show 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] + [Preadditive 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 + letI := P.additive + letI := 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 + letI := P.additive + letI := P.linear + show 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..bbf3a93fdb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SchurPackage.lean @@ -0,0 +1,130 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams +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`. +-/ + +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..692342e8f3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorDischarge.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorIntertwine +import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialDet +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. +-/ + +noncomputable section + +namespace RS + +open CategoryTheory MonoidalCategory Category MonoidAlgebra +open Functor.LaxMonoidal Functor.OplaxMonoidal + +open scoped Classical + +/-! ## 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 + letI := P.additive + letI := P.linear + letI := 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 + letI := P.additive + letI := P.linear + letI := P.braided + show (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 + letI := P.additive + letI := P.linear + letI := P.braided + show (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 + letI := P.additive + letI := P.linear + letI := 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..5428a225dc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorIntertwine.lean @@ -0,0 +1,511 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.KoszulAction +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorNonvanishing +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`. +-/ + +noncomputable section + +namespace RS + +open Finset MonoidAlgebra + +open scoped Classical + +/-! ## 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. -/ +private 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 [dif_pos (allEvenEmb_isEven k ℓ n f)] + rw [evenCoord_basis] + by_cases h : f = g + · subst h; rw [if_pos rfl, if_pos rfl] + · rw [if_neg h, if_neg (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 -/ + +/-- 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 + show ∑ 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 [dif_pos (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 => + show 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 [if_pos ⟨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 [dif_pos (allOddEmb_isEven k ℓ n hn g₁)] + rw [evenCoord_basis] + by_cases h : g₁ = g₂ + · subst h; rw [if_pos rfl, if_pos rfl] + · rw [if_neg h, if_neg (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 + show ∑ 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 [dif_pos (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..d36b397a24 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/TotalDimension.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 +-/ + +import LeanPool.RegtsSevenster.RS.Common.ExponentialGrowth +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.WordCommutant +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourTotal +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaTensorPower +import LeanPool.RegtsSevenster.RS.Novel.Envelope.Frobenius +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`. +-/ + +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 + letI := 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 + letI := P.additive + letI := P.linear + letI := 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 + 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..d75d96d516 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BlockKill.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 +-/ + +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. +-/ + +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 + | hM 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 + | hadd a b ha hb => + rw [map_add, map_add, LinearMap.comp_add, LinearMap.add_comp, + ha, hb] + | hsmul 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..b4357b2745 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BranchTrace.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 +-/ + +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. +-/ + +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 + show symCast h (MonoidAlgebra.of ℂ _ σ) = _ + rw [symCast, MonoidAlgebra.of_apply, MonoidAlgebra.of_apply] + show 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 + show (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 + haveI := jtSimple_simple lam + haveI := IsSimpleModule.nontrivial + (MonoidAlgebra ℂ (Equiv.Perm (Fin lam.card))) + (jtSimple lam) + haveI : 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..c18d9583b3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CentralElem.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 +-/ + +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. +-/ + +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] [DecidableEq 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.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 [if_pos (Finset.mem_univ k)] + +/-- **Class functions give central elements.** -/ +theorem classElem_mul_comm [Group G] [Fintype G] [DecidableEq G] + (c : G → ℂ) + (hc : ∀ g h : G, c (h * g * h⁻¹) = c g) + (y : MonoidAlgebra ℂ G) : + classElem c * y = y * classElem c := by + induction y using MonoidAlgebra.induction_on with + | hM m => + refine MonoidAlgebra.coeff_injective ?_ + ext k + show (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.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.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 + | hadd a b ha hb => rw [mul_add, add_mul, ha, hb] + | hsmul 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..e7fe97f387 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharClass.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 +-/ + +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). +-/ + +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 [if_pos hp, if_pos hp, colourChar_inv] + · rw [if_neg hp, if_neg 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..84f0e9bf8e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharDecomp.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharEquiv +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. +-/ + +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] + show (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 + show (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] [Fintype 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 + 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 + haveI hnt : Nontrivial V := Module.nontrivial_of_finrank_pos hfpos + haveI : Nontrivial ρ.asModule := hnt + haveI : NeZero ((Nat.card G : ℂ)) := ⟨by + rw [Nat.card_eq_fintype_card] + exact_mod_cast Fintype.card_ne_zero⟩ + haveI : IsSemisimpleRing (MonoidAlgebra ℂ G) := inferInstance + haveI : IsSemisimpleModule (MonoidAlgebra ℂ G) ρ.asModule := + IsSemisimpleRing.isSemisimpleModule + obtain ⟨T, hTsimp⟩ := + IsSemisimpleModule.exists_simple_submodule (MonoidAlgebra ℂ G) + ρ.asModule + obtain ⟨W, hTW⟩ := exists_isCompl T + haveI : Nontrivial (↥T) := IsSimpleModule.nontrivial (MonoidAlgebra ℂ G) T + have hTpos : 0 < Module.finrank ℂ ↥(T.restrictScalars ℂ) := by + haveI : 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, LinearEquiv.coe_toLinearMap] + -- 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 + show (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 _ + rw [h1, map_smul, h2] + -- 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 + show (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 + simp only [restrict_apply] + 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 + simp only [restrict_apply] + 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] [Fintype 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 := + 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..73d22d51a1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharEquiv.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 +-/ + +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`. +-/ + +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] + [FiniteDimensional ℂ V] [FiniteDimensional ℂ 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] [Fintype G] + {S T : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)} + (e : (rhoS S).Equiv (rhoS T)) (g : G) : + nChar S g = nChar T g := by + 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..c82b9e346c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourCycleSum.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharClass +import LeanPool.RegtsSevenster.RS.Common.PermCongr +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. +-/ + +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..a62565a567 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourWeight.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ContentCount +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. +-/ + +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, if_neg hb]) + (fun h => absurd (Finset.mem_univ j) h)] + rw [Multiset.count_replicate, if_pos 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 [if_pos hg, Finset.sum_filter] + exact Finset.sum_congr rfl fun π _ => by + by_cases hf : g ∘ π = g + · rw [if_pos ⟨hg, hf⟩, if_pos hf] + · rw [if_neg (fun hc => hf hc.2), if_neg hf] + · rw [if_neg hg] + rw [Finset.sum_eq_zero fun π _ => + if_neg (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..d538a1b969 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CommutantBound.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharDecomp +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. +-/ + +namespace RS + +open Finset LinearMap Representation +open scoped Classical + +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] [Fintype 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 + 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] [Fintype 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 + 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] [Fintype 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 + rw [intertwining_finrank_sum_right ρ _ S hchar] + haveI := 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 + +/-- 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] [Fintype 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 + 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 + haveI : 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] [Fintype 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 + 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] [Fintype 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 + 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..6cba066217 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ContentCount.lean @@ -0,0 +1,248 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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 + show (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 ?_ + show 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 => ?_⟩ + show 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 + convert this using 1 + simp [Equiv.Perm.inv_def] + +/-! ### 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⟩ + show ((∏ 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..82478d13a5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleFactor.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 +-/ + +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. +-/ + +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..f4eeb92823 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSum.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSumPrep +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.OrbitBridge +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.StabCount +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`. +-/ + +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..034163cae3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSumPrep.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 +-/ + +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. +-/ + +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..e94451c5a4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/EndSum.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 +-/ + +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`. +-/ + +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..7bcaf87fc4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FibreCard.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 +-/ + +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. +-/ + +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..13d0df418b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FixWeight.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight +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`. +-/ + +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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/HVal.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/HVal.lean new file mode 100644 index 0000000000..228fd1d513 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/HVal.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 +-/ + +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)`. +-/ + +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 _ => ?_ + show (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 ?_ + show p.1 < Multiset.count j (p.2.1 + Multiset.replicate (p.1 + 1) j) + rw [Multiset.count_add, Multiset.count_replicate, if_pos 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 + show q.2 < k + 1 + omega + · -- left inverse + intro p hp + refine Sigma.ext rfl (heq_of_eq ?_) + refine Subtype.ext ?_ + show (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 + show (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 + show 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..6e98c253f2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/IdempotentBridge.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable +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. +-/ + +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..cb57ba8f2b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTChar.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FixWeight +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`. +-/ + +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 [if_pos hp, Finset.mul_sum] + refine Finset.sum_congr rfl fun π _ => ?_ + rw [if_pos hp, mul_assoc] + · rw [if_neg hp] + rw [Finset.sum_eq_zero fun π _ => by + rw [if_neg 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 [if_pos 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 [if_neg 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..fa78df6e2d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIntChar.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharDecomp +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}`. +-/ + +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 [if_pos 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 [if_neg 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 ⟨σ, _⟩ + show (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 + show 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..4a9f7b57f0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIrreducible.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTOrtho +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharEquiv +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`. +-/ + +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' + haveI := rhoS_isIrreducible (T j) (hT j) + haveI := rhoS_isIrreducible (T j') (hT j') + haveI : 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 + letI 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 [if_pos hc, if_pos ((hgr j j').mpr ⟨hc.some.symm⟩)] + · rw [if_neg hc, if_neg (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 [if_pos hc, if_pos hc.symm, mul_one] + · rw [if_neg hc, if_neg (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..b764aa6c45 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTOrtho.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairChar +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairTuple +import LeanPool.RegtsSevenster.RS.Classical.SymFun.TCount +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. +-/ + +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 [if_pos ⟨hσ, hτ⟩, Finset.mul_sum] + refine Finset.sum_congr rfl fun π _ => ?_ + rw [if_pos hσ, if_pos hτ]; ring + · rw [if_neg (fun hc => hτ hc.2)] + rw [Finset.sum_eq_zero fun π _ => by + rw [if_neg hτ, mul_zero, mul_zero]] + rw [mul_zero] + · rw [if_neg (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 [if_neg 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 [if_pos hboth, if_pos hboth] + rw [hstep2 σ τ hboth.1 hboth.2, hstep3 σ τ hboth.1 hboth.2, + hstep4 σ τ hboth.1 hboth.2] + push_cast; ring + · rw [if_neg hboth, if_neg 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..4868e19f22 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean @@ -0,0 +1,491 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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) : ℕ), head_maps_head μ hk σ hfix j⟩ + invFun j := ⟨(σ⁻¹ (Fin.castLE hk j) : ℕ), + head_maps_head μ hk σ⁻¹ (fun i hi => by + have h1 := hfix i hi + show σ.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 + show 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 [β, dif_neg (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 [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 + show 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 + show (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 [dif_pos 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) + · show (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 + show fibreCard (Fin.castLE hNk ∘ g) j = + (if h : (j : ℕ) < N then α ⟨(j : ℕ), h⟩ else 0) + by_cases hj : (j : ℕ) < N + · rw [dif_pos 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 [dif_neg 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 [if_neg] + 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 [dif_pos 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 [dif_neg 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 [dif_pos (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 [dif_pos hi] at hsig; rw [dif_pos hi, hsig]; rfl + · rw [dif_neg hi] at hsig; rw [dif_neg 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 [dif_pos hfix] + exact restrictHead_extendTail μ hk σ' + · -- right_inv + intro σ hσ + rw [dif_pos (Finset.mem_filter.mp hσ).2] + exact extendTail_restrictHead μ hk σ (Finset.mem_filter.mp hσ).2 + · -- term matching + intro σ' _ + show ((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 [if_pos hguard, if_pos ((guard_iff σ').mpr hguard)] + exact_mod_cast (comp_eq σ' hguard).symm + · rw [if_neg hguard, + if_neg (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..4b60bc9c86 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTSimple.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIntChar +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIrreducible + +/-! +# The Jacobi–Trudi character is plus-or-minus a native character +-/ + +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 μ + letI := 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..f1ee627fa4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/KillSimples.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 +-/ + +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. +-/ + +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] [Fintype G] + (x : MonoidAlgebra ℂ G) + (hx : ∀ S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G), + IsSimpleModule (MonoidAlgebra ℂ G) S → + ∀ s ∈ S, x * s = 0) : + x = 0 := by + classical + haveI : 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..2a8f13ae37 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedCount.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedFixed +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. +-/ + +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 + show (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 [if_pos 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 [if_neg 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..3283466bb2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedFixed.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 +-/ + +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. +-/ + +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 [dif_pos hσval, dif_pos 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 [dif_pos hi]; simp only [Function.comp_apply]; congr 1 + · rw [dif_neg hi] + right_inv p := by + apply Prod.ext + · apply Subtype.ext; funext j; simp only [Function.comp_apply] + rw [dif_pos (show (Fin.castLE h j : ℕ) < m from j.2)]; congr 1 + · funext ⟨i, hi⟩; simp only + rw [dif_neg (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, dif_pos him] at hi; exact hi⟩ + else + Sum.inr + ⟨⟨i, Nat.not_lt.mp him⟩, by rw [glue_eq, dif_neg 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, dif_pos 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, dif_neg 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 [dif_pos (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 [dif_neg (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..dd41fa1603 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeAction.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BlockKill +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. +-/ + +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 + show ((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 + haveI := 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 + | hM 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 + | hadd a b ha hb => + intro m hm + rw [add_smul] + exact p.add_mem (ha m hm) (hb m hm) + | hsmul 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..8c89216267 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeFaithful.lean @@ -0,0 +1,354 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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] [DecidableEq 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 + 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, if_neg 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] [DecidableEq G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) : + nPsi S (nProjector S) = 1 := by + 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 [if_pos ⟨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] [DecidableEq G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) : + mPsi S (nProjector S) = LinearMap.id := by + 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] [DecidableEq G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) : + Function.Injective (mPsiLin S) := by + 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] [DecidableEq G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) : + Function.Surjective (mPsiLin S) := by + 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] [DecidableEq 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 + 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] + show 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..e73fc779f4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeTable.lean @@ -0,0 +1,231 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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] [DecidableEq 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 + 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 + haveI hnt : Nontrivial (Subrepresentation (rhoS S)) := by + refine ⟨⟨⊥, ⊤, ?_⟩⟩ + haveI : 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] [DecidableEq 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 + haveI := rhoS_isIrreducible S hS + haveI := 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 + haveI : 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 [if_pos 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 + haveI : 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 [if_neg heq] + simp + +open scoped Classical in +/-- **Idempotency of the native projector.** -/ +theorem nProjector_idem [Group G] [Fintype G] [DecidableEq G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) : + nProjector S * nProjector S = nProjector S := by + 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 [if_pos heq, one_smul, one_smul, sub_self] + · rw [if_neg 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] [DecidableEq G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (y : MonoidAlgebra ℂ G) : + nProjector S * y = y * nProjector S := + classElem_mul_comm (nCoeff S) (nCoeff_classFun S) y + +/-- The projector's coefficient at the identity. -/ +theorem nProjector_coeff_one [Group G] [Fintype G] [DecidableEq G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) : + (nProjector S).coeff 1 = + ((nDim S : ℂ) ^ 2) / (Fintype.card G : ℂ) := by + 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] [DecidableEq G] + (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) + (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) : + Module.finrank ℂ + (LinearMap.range (mulLeft ℂ (nProjector S))) = + nDim S ^ 2 := by + 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..5ea1bd5bba --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/OrbitBridge.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 +-/ + +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. +-/ + +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 -/ + +-- Raised budget: 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, if_neg (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, if_pos rfl] + exact card_singleton_orbits π + · -- m ≥ 2 + have hm_ge2 : 2 ≤ m := by omega + rw [if_neg (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..d6caa93717 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/Package.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairingPos +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTPad +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. +-/ + +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..dc46fbc22e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PackageAssembly.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowth +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.IdempotentBridge +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`. +-/ + +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 + haveI := jtSimple_simple μ + haveI := IsSimpleModule.nontrivial + (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) (jtSimple μ) + haveI : 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..09edc8fb90 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairChar.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 +-/ + +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. +-/ + +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..3d6b48f6a8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairInner.lean @@ -0,0 +1,235 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 [if_pos ⟨hm.1, hm.2, hf⟩, if_pos ⟨hm, hf⟩] + · rw [if_neg (fun hc => hf hc.2.2), + if_neg (fun hc => hf hc.2)] + · rw [if_neg (fun hc => hm ⟨hc.1, hc.2.1⟩), + if_neg (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 [if_pos hm, Finset.card_filter] + refine Finset.sum_congr rfl fun π _ => ?_ + by_cases hf : p ∘ π = p + · rw [if_pos ⟨hm, hf⟩, if_pos hf] + · rw [if_neg (fun hc => hf hc.2), if_neg hf] + · rw [if_neg hm] + rw [Finset.sum_eq_zero fun π _ => + if_neg (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 [if_pos hm, if_pos (hiff.mp hm)] + refine Finset.prod_congr rfl fun c _ => ?_ + rw [pairFibre_eq_count] + rfl + · rw [if_neg hm, if_neg (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 [if_pos hm, if_pos 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 [if_neg hm, if_neg 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..0fd1c2cf50 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairOrbit.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 +-/ + +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. +-/ + +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] + show 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..0b81e0aa1e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairStab.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 +-/ + +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. +-/ + +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 + show 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 _ => ?_ + show finProdFinEquiv (p i) = j ↔ p i = finProdFinEquiv.symm j + exact Equiv.apply_eq_iff_eq_symm_apply finProdFinEquiv + 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..92115cdc06 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairTuple.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 +-/ + +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. +-/ + +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..74c924e3c7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean @@ -0,0 +1,474 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BranchTrace +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedCount +import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffSplit +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. +-/ + +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 : ℂ) * + MvPolynomial.coeff (∑ a, Finsupp.single a (α a)) + ((∏ i, hSub (Finset.univ : Finset (Fin k)) (β i)) * + (∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ (n - m)) := 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 [if_pos hw]] + rw [← Finset.sum_mul] + rw [if_pos 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 [if_neg hw, Finset.sum_eq_zero fun σ _ => by rw [if_neg 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 [if_pos hw, if_pos 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 [if_neg hw, if_neg 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 →₀ ℕ) : + MvPolynomial.coeff w ((jtMat v).det * Q) = + ∑ σ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if ∀ i : Fin k, + 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) + then MvPolynomial.coeff w + ((∏ i, hSub (Finset.univ : Finset (Fin k)) + (((v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ)).toNat)) * Q) + 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 [if_pos hp, if_pos hp] + · rw [if_neg hp, if_neg hp, zero_mul, MvPolynomial.coeff_zero] + +-- 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 : ℂ) * + MvPolynomial.coeff + (∑ i : Fin k, Finsupp.single i (eVec mu k i)) + ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r * + altDet (eVec lam k)) := 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 : + MvPolynomial.coeff (∑ i : Fin k, Finsupp.single i (eVec mu k i)) + (Q * altDet (eVec lam k)) = + ∑ τ : Equiv.Perm (Fin k), ∑ σ' : Equiv.Perm (Fin k), + ((Equiv.Perm.sign τ : ℤ) : ℂ) * ((Equiv.Perm.sign σ' : ℤ) : ℂ) * + (if guard_mu τ ∧ guard_lam σ' + then MvPolynomial.coeff (∑ a, Finsupp.single a (α τ a)) + ((∏ i, hSub (Finset.univ : Finset (Fin k)) (β σ' i)) * Q) + 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 [if_pos 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, if_pos hσ, if_pos ⟨hguard_mu, hσ⟩, hmargin] + · rw [mul_assoc, if_neg hσ, if_neg (fun ⟨_, h⟩ => hσ h), mul_zero] + · rw [if_neg 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 MvPolynomial.coeff (∑ a, Finsupp.single a (α τ a)) + ((∏ i, hSub (Finset.univ : Finset (Fin k)) (β σ' i)) * Q) + else 0)) = 0 := by + apply Finset.sum_eq_zero; intro σ' _ + rw [if_neg (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 MvPolynomial.coeff (∑ a, Finsupp.single a (α τ a)) + ((∏ i, hSub (Finset.univ : Finset (Fin k)) (β σ' i)) * Q) + 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 [if_pos hσ_exp, if_pos hτ_exp] + rw [if_pos ⟨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 [if_pos hσ_exp, if_neg hτ_exp] + rw [if_neg (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 [if_neg hσ_exp] + rw [if_neg (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..6cf75f7c07 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PermModule.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 +-/ + +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 α`. +-/ + +namespace RS + +open Finset Equiv MonoidAlgebra + +open scoped Classical + +/-- 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 + show g.1 ∘ ⇑(1 : Equiv.Perm (Fin n))⁻¹ = g.1 + simp + mul_smul π ρ g := by + apply Subtype.ext + show 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 + show 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 + show ∑ 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 + show ((coeffLinearEquiv ℂ) + (MonoidAlgebra.single (π • g) (1 : ℂ))) g = + if π • g = g then 1 else 0 + rw [coeffLinearEquiv_apply] + simp [MonoidAlgebra.coeff, 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..e3a442dd29 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PowerSurj.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 +-/ + +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. +-/ + +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 [if_pos (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..eef81fa95a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/RegularTrace.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 +-/ + +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. +-/ + +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] [DecidableEq 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.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] [DecidableEq 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..08a20a9d0b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SameCycleQuot.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 +-/ + +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. +-/ + +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 + show 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 + show 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 + show 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..926d67503b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ScalarTrace.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 +-/ + +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)`. +-/ + +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] [DecidableEq 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 + 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 + haveI : 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..54906bda85 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SchurAction.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 +-/ + +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. +-/ + +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 + haveI : 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] [DecidableEq 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 + 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] [DecidableEq 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 := + 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..7042b5c160 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SigmaCycleType.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 +-/ + +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. +-/ + +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 + rw [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..3ab9eee8dd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignResolve.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SymFun.DimFormula +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. +-/ + +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..777da2722a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorTrace +import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialH +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. +-/ + +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 [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..d11ea3da1d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.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 +-/ + +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`. +-/ + +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] [Fintype 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 + -- Pick a nonzero element m : M. + haveI := 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 [φ, toSpanSingleton, smulRight] 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. + haveI : NeZero ((Nat.card G : ℂ)) := ⟨by + rw [Nat.card_eq_fintype_card] + exact_mod_cast Fintype.card_ne_zero⟩ + haveI : 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..55f7a907be --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowth.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 +-/ + +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`. +-/ + +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 _ _ => Nat.zero_le _) + (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..edee162a6f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowthSharp.lean @@ -0,0 +1,129 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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..9d0fbbb877 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareStair.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 +-/ + +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. +-/ + +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..41e5675235 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/StabCount.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 +-/ + +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)!`. +-/ + +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. -/ +private 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..f9979547c7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorNonvanishing.lean @@ -0,0 +1,130 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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..2e81265ff5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorTrace.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 +-/ + +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 : ℂ)`. +-/ + +namespace RS + +open Finset Equiv MonoidAlgebra + +open scoped Classical + +/-! ## 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 + show g ∘ ⇑(1 : Equiv.Perm (Fin n))⁻¹ = g + simp + mul_smul π ρ g := by + show 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..616936b38f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/WordCommutant.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 +-/ + +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)`. +-/ + +namespace RS + +open Finset Representation +open scoped Classical + +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 ∘ σ) + +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)))⟩ + +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 + +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 + +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 [dif_pos h, Pi.add_apply] + rfl + · simp only [dif_neg h, Pi.add_apply, add_zero] + map_smul' z T := by + funext c + by_cases h : ∃ p, wordPairCounts p = c + · simp only [dif_pos h, Pi.smul_apply, RingHom.id_apply] + rfl + · simp only [dif_neg h, Pi.smul_apply, smul_zero] + +private theorem commutantEntries_injective [Fintype α] + {ρ : Representation ℂ (Equiv.Perm (Fin n)) + ((Fin n → α) → ℂ)} (M : MonomialWordAction ρ) : + Function.Injective (commutantEntries ρ) := by + classical + 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, + dif_pos 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 + +/-- 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..8e02889051 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourAction.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjTop +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. +-/ + +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 dif_pos 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 dif_neg 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 => + show 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..1df98b43d9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConj.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Super.PowBraid +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. +-/ + +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 => ?_) + show (colourPowerEquiv k ℓ n).evenEquiv + ((g₂ : SuperVect.Hom _ _).evenMap + ((g₁ : SuperVect.Hom _ _).evenMap + ((colourPowerEquiv k ℓ n).evenEquiv.symm x))) = _ + show _ = (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 => ?_) + show (colourPowerEquiv k ℓ n).oddEquiv + ((g₂ : SuperVect.Hom _ _).oddMap + ((g₁ : SuperVect.Hom _ _).oddMap + ((colourPowerEquiv k ℓ n).oddEquiv.symm x))) = _ + show _ = (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 => ?_) + show (colourPowerEquiv k ℓ n).evenEquiv + ((colourPowerEquiv k ℓ n).evenEquiv.symm x) = x + rw [(colourPowerEquiv k ℓ n).evenEquiv.apply_symm_apply] + · refine LinearMap.ext (fun x => ?_) + show (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..6ae330c1c1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjStep.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 +-/ + +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. +-/ + +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.induction_on with + | zero => simp + | 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] + +-- Raised budget: 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 + show ((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 => ?_) + show ((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..8d8a418e9e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean @@ -0,0 +1,2376 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TwoBasis +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. +-/ + +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.induction_on with + | zero => rfl + | 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 + show (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] + show 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 + show (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] + show 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 + show (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] + show 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 + show (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] + show 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 + show (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 + show (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 + show (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 _) + (by rw [SuperVect.koszul_ee])))) ?_ + 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 -/ + +-- Raised budget: 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 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 + haveI : Subsingleton SuperVect.tensorUnit.odd := + inferInstanceAs (Subsingleton PUnit) + haveI : 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 + show 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] + show (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 if_neg (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 if_pos ⟨(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. + 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.induction_on with + | zero => exact hP0 + | 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.induction_on with + | zero => + have h0elem : (((((0 : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even), 0) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] y, + 0) : (superPow (stdSuperPair k ℓ) 2).even) = + 0 := by + refine Eq.trans (congrArg (fun t => + ((t, (0 : (superPow (stdSuperPair k ℓ) 1).odd + ⊗[ℂ] (stdSuperPair k ℓ).odd)) : + (superPow (stdSuperPair k ℓ) 2).even)) + (show ((((0 : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even), 0) : + (superPow (stdSuperPair k ℓ) 1).even)) + ⊗ₜ[ℂ] y = 0 from + TensorProduct.zero_tmul _ y)) ?_ + exact Prod.ext_iff.mpr ⟨rfl, rfl⟩ + exact Eq.mpr (congrArg P h0elem) hP0 + | 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 + refine Eq.trans (congrArg (fun t => + ((((((0 : (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even), t) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] y), + (0 : (superPow (stdSuperPair k ℓ) 1).odd + ⊗[ℂ] (stdSuperPair k ℓ).odd)) : + (superPow (stdSuperPair k ℓ) 2).even)) + (subsingleton_tmul_eq_zero a₂)) ?_ + refine Eq.trans (congrArg (fun t => + ((t, (0 : (superPow (stdSuperPair k ℓ) 1).odd + ⊗[ℂ] (stdSuperPair k ℓ).odd)) : + (superPow (stdSuperPair k ℓ) 2).even)) + (show ((((0 : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even), (0 : + (superPow (stdSuperPair k ℓ) 0).odd ⊗[ℂ] + (stdSuperPair k ℓ).odd)) : + (superPow (stdSuperPair k ℓ) 1).even)) + ⊗ₜ[ℂ] y = 0 from + TensorProduct.zero_tmul _ y)) ?_ + exact Prod.ext_iff.mpr ⟨rfl, rfl⟩ + exact Eq.mpr (congrArg P h0elem) hP0 + · -- The odd-odd block. + induction v₂ using TensorProduct.induction_on with + | zero => exact hP0 + | 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.induction_on with + | zero => + have h0elem : ((0, ((((0 : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z)) : + (superPow (stdSuperPair k ℓ) 2).even) = 0 := by + refine Eq.trans (congrArg (fun t => + (((0 : (superPow (stdSuperPair k ℓ) 1).even + ⊗[ℂ] (stdSuperPair k ℓ).even), t) : + (superPow (stdSuperPair k ℓ) 2).even)) + (show ((((0 : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), 0) : + (superPow (stdSuperPair k ℓ) 1).odd)) + ⊗ₜ[ℂ] z = 0 from + TensorProduct.zero_tmul _ z)) ?_ + exact Prod.ext_iff.mpr ⟨rfl, rfl⟩ + exact Eq.mpr (congrArg P h0elem) hP0 + | 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 + refine Eq.trans (congrArg (fun t => + (((0 : (superPow (stdSuperPair k ℓ) 1).even + ⊗[ℂ] (stdSuperPair k ℓ).even), + ((((0 : (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), t) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z)) : + (superPow (stdSuperPair k ℓ) 2).even)) + (subsingleton_tmul_eq_zero b₂)) ?_ + refine Eq.trans (congrArg (fun t => + (((0 : (superPow (stdSuperPair k ℓ) 1).even + ⊗[ℂ] (stdSuperPair k ℓ).even), t) : + (superPow (stdSuperPair k ℓ) 2).even)) + (show ((((0 : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), (0 : + (superPow (stdSuperPair k ℓ) 0).odd ⊗[ℂ] + (stdSuperPair k ℓ).even)) : + (superPow (stdSuperPair k ℓ) 1).odd)) + ⊗ₜ[ℂ] z = 0 from + TensorProduct.zero_tmul _ z)) ?_ + exact Prod.ext_iff.mpr ⟨rfl, rfl⟩ + exact Eq.mpr (congrArg P h0elem) hP0 + +/-! ### 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 + show (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 + show (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 + show (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 _) + (by rw [SuperVect.koszul_eo])))) ?_ + 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 _) + (by rw [SuperVect.koszul_oe])))) ?_ + 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 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 + haveI : Subsingleton SuperVect.tensorUnit.odd := + inferInstanceAs (Subsingleton PUnit) + haveI : 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 + show 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] + show (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 if_neg (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 if_neg (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. + 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.induction_on with + | zero => exact hP0 + | 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.induction_on with + | zero => + have h0elem : (((((0 : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even), 0) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, + 0) : (superPow (stdSuperPair k ℓ) 2).odd) = + 0 := by + refine Eq.trans (congrArg (fun t => + ((t, (0 : (superPow (stdSuperPair k ℓ) 1).odd + ⊗[ℂ] (stdSuperPair k ℓ).even)) : + (superPow (stdSuperPair k ℓ) 2).odd)) + (show ((((0 : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even), 0) : + (superPow (stdSuperPair k ℓ) 1).even)) + ⊗ₜ[ℂ] w = 0 from + TensorProduct.zero_tmul _ w)) ?_ + exact Prod.ext_iff.mpr ⟨rfl, rfl⟩ + exact Eq.mpr (congrArg P h0elem) hP0 + | 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 + refine Eq.trans (congrArg (fun t => + ((((((0 : (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even), t) : + (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w), + (0 : (superPow (stdSuperPair k ℓ) 1).odd + ⊗[ℂ] (stdSuperPair k ℓ).even)) : + (superPow (stdSuperPair k ℓ) 2).odd)) + (subsingleton_tmul_eq_zero a₂)) ?_ + refine Eq.trans (congrArg (fun t => + ((t, (0 : (superPow (stdSuperPair k ℓ) 1).odd + ⊗[ℂ] (stdSuperPair k ℓ).even)) : + (superPow (stdSuperPair k ℓ) 2).odd)) + (show ((((0 : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).even), (0 : + (superPow (stdSuperPair k ℓ) 0).odd ⊗[ℂ] + (stdSuperPair k ℓ).odd)) : + (superPow (stdSuperPair k ℓ) 1).even)) + ⊗ₜ[ℂ] w = 0 from + TensorProduct.zero_tmul _ w)) ?_ + exact Prod.ext_iff.mpr ⟨rfl, rfl⟩ + exact Eq.mpr (congrArg P h0elem) hP0 + · -- The odd-even block. + induction v₂ using TensorProduct.induction_on with + | zero => exact hP0 + | 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.induction_on with + | zero => + have h0elem : ((0, ((((0 : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), 0) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y)) : + (superPow (stdSuperPair k ℓ) 2).odd) = 0 := by + refine Eq.trans (congrArg (fun t => + (((0 : (superPow (stdSuperPair k ℓ) 1).even + ⊗[ℂ] (stdSuperPair k ℓ).odd), t) : + (superPow (stdSuperPair k ℓ) 2).odd)) + (show ((((0 : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), 0) : + (superPow (stdSuperPair k ℓ) 1).odd)) + ⊗ₜ[ℂ] y = 0 from + TensorProduct.zero_tmul _ y)) ?_ + exact Prod.ext_iff.mpr ⟨rfl, rfl⟩ + exact Eq.mpr (congrArg P h0elem) hP0 + | 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 + refine Eq.trans (congrArg (fun t => + (((0 : (superPow (stdSuperPair k ℓ) 1).even + ⊗[ℂ] (stdSuperPair k ℓ).odd), + ((((0 : (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), t) : + (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y)) : + (superPow (stdSuperPair k ℓ) 2).odd)) + (subsingleton_tmul_eq_zero b₂)) ?_ + refine Eq.trans (congrArg (fun t => + (((0 : (superPow (stdSuperPair k ℓ) 1).even + ⊗[ℂ] (stdSuperPair k ℓ).odd), t) : + (superPow (stdSuperPair k ℓ) 2).odd)) + (show ((((0 : + (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] + (stdSuperPair k ℓ).odd), (0 : + (superPow (stdSuperPair k ℓ) 0).odd ⊗[ℂ] + (stdSuperPair k ℓ).even)) : + (superPow (stdSuperPair k ℓ) 1).odd)) + ⊗ₜ[ℂ] y = 0 from + TensorProduct.zero_tmul _ y)) ?_ + exact Prod.ext_iff.mpr ⟨rfl, rfl⟩ + exact Eq.mpr (congrArg P h0elem) hP0 + +/-! ### 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 + show 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 + show 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 + show 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 show 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 show 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 show 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 -/ + +-- Raised budget: 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 + show P w + have hP0 : P 0 := by + rw [hP] + beta_reduce + simp only [map_zero] + show (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 [dif_pos hfh] + rw [dif_pos (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 [dif_neg hfh] + rw [dif_neg (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 [dif_pos hfh] + rw [dif_pos (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 [dif_neg hfh] + rw [dif_neg (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.induction_on with + | zero => exact hP0 + | 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.induction_on with + | zero => exact hP0 + | 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 + show (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 + show (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 + show P w + have hP0 : P 0 := by + rw [hP] + beta_reduce + simp only [map_zero] + show (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 [dif_pos hfh] + rw [dif_pos (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 [dif_neg hfh] + rw [dif_neg (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 [dif_pos hfh] + rw [dif_pos (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 [dif_neg hfh] + rw [dif_neg (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.induction_on with + | zero => exact hP0 + | 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.induction_on with + | zero => exact hP0 + | 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 + +-- Raised budget: 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..4e74b25903 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourEval.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 +-/ + +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. +-/ + +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..5bd45d5cf8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourExtendSwap.lean @@ -0,0 +1,460 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 ι] [DecidableEq ι] + [Fintype κ] [DecidableEq κ] + (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.induction_on with + | zero => + simp only [map_zero, Pi.zero_apply] + change 0 = f 0 x; simp [map_zero] + | 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 -/ + +-- Raised budget: 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 -/ + +-- Raised budget: 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 + show (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] + show 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 + show (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] + show 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..edbf38814d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourFormMatch.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 +-/ + +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. +-/ + +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] + show (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 [dif_pos h, if_pos h] + by_cases hb : a.val + ℓ = b.val + · rw [if_pos hb, + if_pos (show b = ⟨a.val + ℓ, by omega⟩ from + Fin.ext (show b.val = a.val + ℓ by omega))] + norm_num + · rw [if_neg hb, + if_neg (show ¬(b.val + ℓ = a.val) by omega), + if_neg (show ¬(b = ⟨a.val + ℓ, by omega⟩) from + fun he => hb (by + have hv : b.val = a.val + ℓ := congrArg Fin.val he + omega))] + · rw [dif_neg h, if_neg h, + if_neg (show ¬(a.val + ℓ = b.val) by + have := b.isLt + omega)] + by_cases hb : b.val + ℓ = a.val + · rw [if_pos hb, + if_pos (show b = ⟨a.val - ℓ, by omega⟩ from + Fin.ext (show b.val = a.val - ℓ by omega))] + norm_num + · rw [if_neg hb, + if_neg (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..ea45f60373 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMerge.lean @@ -0,0 +1,1157 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge +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. +-/ + +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; show 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 + show 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 + show 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 + show 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 + show 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 + show 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') + show (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 + show (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 + show (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 + show (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 + show (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 + show (SuperVect.assocAux _ _ _ _ _ _).symm + ((v ⊗ₜ[ℂ] (((0 : _), w₁ ⊗ₜ[ℂ] x₁) : _), (0 : _)) : _) = _ + exact SuperVect.assocAux_symm_eo v w₁ x₁ + +/-! ### Full chain reduction on pure tensor generators -/ + +-- Raised budget: 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) ∘ α⁻¹ + show (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] + show 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) ∘ α⁻¹ + show (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] + show 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 + show (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 + show (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 + show (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] + show 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 + show (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] + show 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 + show (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 + show (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 -/ + +-- Raised budget: 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. +/-- 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 + show (LinearEquiv.funUnique + {c : MixedColouring k ℓ 0 // c.IsEven} ℂ ℂ).symm w' _ = w' + rfl + simp only [hpow, LinearEquiv.map_smul, + dif_pos 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 [dif_neg 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 + · -- ═══════ b + 1, EVEN COMPONENT ═══════ + 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.induction_on with + | zero => + simp only [hGoal] + erw [ep_zero, map_zero, LinearEquiv.map_zero, Pi.zero_apply] + split_ifs with h + · exact (mul_zero _).symm + · rfl + | 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.induction_on with + | zero => + simp only [hGoal] + erw [ep_zero, map_zero, LinearEquiv.map_zero, Pi.zero_apply] + split_ifs with h + · exact (mul_zero _).symm + · rfl + | 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) + · -- ═══════ b + 1, ODD COMPONENT ═══════ + 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.induction_on with + | zero => + simp only [hGoal] + erw [op_zero, map_zero, LinearEquiv.map_zero, Pi.zero_apply] + split_ifs with h + · exact (mul_zero _).symm + · rfl + | 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.induction_on with + | zero => + simp only [hGoal] + erw [op_zero, map_zero, LinearEquiv.map_zero, Pi.zero_apply] + split_ifs with h + · exact (mul_zero _).symm + · rfl + | 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) + +-- Raised budget: 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..623859d626 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean @@ -0,0 +1,920 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show (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 + show (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 + show (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 + show (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) -/ + +-- Raised budget: 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 + show (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] + show 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 + show (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] + show 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 + show (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] + show 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 + show (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] + show 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 {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 + show (LinearEquiv.funUnique + {c : MixedColouring k ℓ 0 // c.IsEven} ℂ ℂ).symm w' _ = w' + rfl + simp only [hpow, LinearEquiv.map_smul, + dif_neg 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 [dif_pos 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 + · -- ═══════ b + 1, ODD COORDINATES ═══════ + 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.induction_on with + | zero => + simp only [hGoal] + erw [op_zero, map_zero, LinearEquiv.map_zero, Pi.zero_apply] + split_ifs with h + · rfl + · exact (mul_zero _).symm + | 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.induction_on with + | zero => + simp only [hGoal] + erw [op_zero, map_zero, LinearEquiv.map_zero, Pi.zero_apply] + split_ifs with h + · rfl + · exact (mul_zero _).symm + | 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) + · -- ═══════ b + 1, EVEN COORDINATES ═══════ + 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.induction_on with + | zero => + simp only [hGoal] + erw [op_zero, map_zero, LinearEquiv.map_zero, Pi.zero_apply] + split_ifs with h + · rfl + · exact (mul_zero _).symm + | 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.induction_on with + | zero => + simp only [hGoal] + erw [op_zero, map_zero, LinearEquiv.map_zero, Pi.zero_apply] + split_ifs with h + · rfl + · exact (mul_zero _).symm + | 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) + +-- Raised budget: specializing the mutual induction re-elaborates +-- the paired statement. +/-- **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, + 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 + +-- Raised budget: 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..88c02f8406 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairing.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 +-/ + +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..23982bef85 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairingSymm.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 +-/ + +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. +-/ + +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*} [DecidableEq α] [LinearOrder α] + (S : Finset α) : + ((S ×ˢ S).filter (fun p : α × α => p.1 < p.2)).card = + ((S ×ˢ S).filter (fun p : α × α => p.2 < p.1)).card := by + 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*} + [DecidableEq α] [LinearOrder α] (S : Finset α) : + 2 * ((S ×ˢ S).filter + (fun p : α × α => p.1 < p.2)).card = + S.card * S.card - S.card := by + 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..e9060f598d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPower.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 +-/ + +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. +-/ + +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..0d0c4ddc82 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourTotal.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Super.TotalSpace +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. +-/ + +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 [dif_pos hc] + change (colourSwapWord k ℓ (adjWord σ)).evenMap + (fun a => v a.val) ⟨c, hc⟩ = _ + rw [colourSwapWord_evenMap, wordSign_eq_oddInversions, + wordPerm_adjWord] + · rw [dif_neg hc] + change (colourSwapWord k ℓ (adjWord σ)).oddMap + (fun a => v a.val) ⟨c, hc⟩ = _ + rw [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..8ae59ca4e2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourWord.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourExtendSwap +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. +-/ + +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 => + show 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 => + show ((colourSwap k ℓ (n + 1) i.val (by omega)) : + SuperVect.Hom _ _).evenMap + (((colourSwapWord k ℓ w) : + SuperVect.Hom _ _).evenMap F) c = _ + show 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] + show 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] + show (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 => + show 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..9354001a2c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/OrthonormalBasis.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 +-/ + +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`. +-/ + +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..afddcc6bcd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/PowBraid.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 +-/ + +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. +-/ + +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..90f6b675ab --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/SuperVect.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 +-/ + +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. +-/ + +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 + show 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 + show 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 + show 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 + show 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 + show 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 + show 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 + show 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 + show 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 + show (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 + show (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 + show (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 + show (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..beeff49bbc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/SymplecticBasis.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 +-/ + +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 * ℓ)`. +-/ + +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..b5ea4983b0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/TotalSpace.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 +-/ + +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. +-/ + +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 => ?_ + show ((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 => ?_ + show ((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..85ec7ca27a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/WordSignPerm.lean @@ -0,0 +1,315 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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] + show adjSign c a b * (-1 : ℂ) ^ _ = (-1 : ℂ) ^ (_ + 1) + rw [adjSign, if_pos 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] + show adjSign c a b * (-1 : ℂ) ^ (_ + 1) = (-1 : ℂ) ^ _ + rw [adjSign, if_pos 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] + show adjSign c a b * (-1 : ℂ) ^ _ = (-1 : ℂ) ^ _ + rw [adjSign, if_neg 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 => + show 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..81fde2f08a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantExpand.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 +-/ + +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`. +-/ + +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 →₀ ℕ) : + MvPolynomial.coeff w₀ + (P * (powMat (fun _ : Fin k => 0)).det) = + ∑ τ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign τ : ℤ) : ℂ) * + (if stairShift τ ≤ w₀ + then MvPolynomial.coeff (w₀ - stairShift τ) P + 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 + show (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 [if_pos hle, if_pos hle, mul_one] + · rw [if_neg hle, if_neg 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..8b976ed208 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantPieri.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 +-/ + +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. +-/ + +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, if_pos 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 _ _, if_neg 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 [if_pos (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..eb95ddbaee --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantStrict.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 +-/ + +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. +-/ + +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 + show (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) : + MvPolynomial.coeff (∑ i, Finsupp.single i (w i)) (altDet e) = + if e = w then 1 else 0 := by + classical + by_cases heq : e = w + · subst heq + rw [if_pos 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 [if_neg 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 [if_neg (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..956ecffa0a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/Bialternant.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 +-/ + +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_δ`. +-/ + +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 => ?_ + show 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_upperTriangular] + · refine Finset.prod_eq_one fun i _ => ?_ + show 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 + show 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..c37a7d91ae --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialDet.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialH +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`. +-/ + +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_upperTriangular (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, if_pos 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..db00303e35 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialH.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 +-/ + +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. +-/ + +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..9378669be4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffExtract.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 +-/ + +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. +-/ + +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) : + MvPolynomial.coeff (∑ i, Finsupp.single i (e i)) + ((Matrix.of fun i j : Fin k => + (X j : MvPolynomial (Fin k) ℂ) ^ (e i)).det) = 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 [if_pos (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, if_neg 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..fd4de21887 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffSplit.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 +-/ + +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. +-/ + +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) : + MvPolynomial.coeff (∑ a, Finsupp.single a (α a)) (P * Q) = + ∑ w ∈ Fintype.piFinset + (fun _ : Fin k => Finset.range (n + 1)), + (if ∀ a, w a ≤ α a + then MvPolynomial.coeff + (∑ a, Finsupp.single a (α a - w a)) P * + MvPolynomial.coeff (∑ a, Finsupp.single a (w a)) Q + 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 + show 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 ?_ ?_ + · show (∑ a, Finsupp.single a (α a - p.2 a)) = p.1 + ext a + rw [sum_single_apply] + have := hpt a + omega + · show (∑ a, Finsupp.single a (p.2 a)) = p.2 + ext a + rw [sum_single_apply] + · -- right inverse + intro w hw + funext a + show (∑ 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] + show 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..29de571a81 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DeltaSeq.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 +-/ + +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₀`. +-/ + +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, if_pos 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, if_neg (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 [if_pos hπ, hπ, Equiv.Perm.cycleType_one, + Multiset.map_zero, Multiset.prod_zero] + · rw [if_neg 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, if_neg] + 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 [if_neg hπ, mul_zero]) + (fun hmem => absurd (Finset.mem_univ _) hmem)] at h + rw [if_pos 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..d295514bce --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DescVandermonde.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 +-/ + +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`. +-/ + +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..d05657c9ca --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DimFormula.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SymFun.DeltaSeq +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. +-/ + +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, if_pos 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, if_neg 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..a74edf1e7d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/EHConv.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 +-/ + +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`. +-/ + +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..a9041041a2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/EHDischarge.lean @@ -0,0 +1,35 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SymFun.HInsert +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. +-/ + +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..cfc2f6e9d2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HInsert.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 +-/ + +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` +-/ + +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. + show ∑ 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 + show (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..0af9cc43eb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HProdCoeff.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 +-/ + +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`. +-/ + +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 [monomial_mul, 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 →₀ ℕ) : + MvPolynomial.coeff w (∏ i, hSub (Finset.univ : Finset (Fin k)) (c i)) = + (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..bd3011196e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HSubZ.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 +-/ + +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. +-/ + +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, if_pos (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, if_neg (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..e55d5f1596 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HookVanishing.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 +-/ + +import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams +import LeanPool.RegtsSevenster.RS.Classical.SymFun.RecurrenceFromVanishing +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`. +-/ + +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..3ed2d6cb40 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTDetExpand.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 +-/ + +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. +-/ + +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 [if_pos 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 [if_neg 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 →₀ ℕ) : + MvPolynomial.coeff w ((jtMat v).det) = + ∑ σ : Equiv.Perm (Fin k), + ((Equiv.Perm.sign σ : ℤ) : ℂ) * + (if ∀ i : Fin k, + 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) + then MvPolynomial.coeff w (∏ i, hSub (Finset.univ : Finset (Fin k)) + (((v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ)).toNat)) + 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 [if_pos hp, if_pos hp] + · rw [if_neg hp, if_neg hp, MvPolynomial.coeff_zero] + +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..0fbfc812b3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTGuard.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 +-/ + +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. +-/ + +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..a6d0d4ad96 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/LGVStrict.lean @@ -0,0 +1,780 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +open scoped Classical + +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, if_pos (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 + +/-- Least crossing height. -/ +private noncomputable def cH {s m : ℕ} (F : Fin s → Finset (Fin m)) + (hc : Crossing F) : ℕ := + Nat.find hc + +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, if_neg hj, if_neg 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, if_pos rfl]; exact key _ _ + · by_cases hji' : j = i' + · subst hji'; rw [swapFam, if_neg hji, if_pos 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, if_pos 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, if_neg (Ne.symm hne), if_pos 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, if_pos 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, if_neg (Ne.symm hne), if_pos rfl] + by_cases hji : j = i + · rw [hji] + rw [swapFam, if_pos rfl] + rw [hGi, hGi', keyPre, keySuf, Finset.filter_union_filter_not_eq] + · by_cases hji' : j = i' + · rw [hji'] + rw [swapFam, if_neg (Ne.symm hne), if_pos 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 -/ + +/-- 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] + +/-- 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) + +/-- 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 + +/-- 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 -/ + +/-- 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..1209d39526 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PieriChain.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantStrict +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. +-/ + +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 : ℕ, MvPolynomial.coeff (∑ i, Finsupp.single i (w i)) + ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r * altDet e) = 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 : ℕ, + MvPolynomial.coeff (∑ j, Finsupp.single j (w j)) + ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r * + altDet (Function.update e i₀ (e i₀ + 1))) = ↑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, MvPolynomial.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 ∧ + MvPolynomial.coeff (∑ i, Finsupp.single i (eVec mu k i)) + ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r * + altDet (eVec lam k)) = 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 _ _), + if_pos 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 [if_pos 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 : ℕ, + MvPolynomial.coeff (∑ j, Finsupp.single j (eVec mu k j)) + ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r * + altDet (Function.update (eVec lam k) i + (eVec lam k i + 1))) = ↑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, MvPolynomial.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..1267187710 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowCount.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 +-/ + +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`. +-/ + +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 →₀ ℕ) : + MvPolynomial.coeff w + ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ Fintype.card T) = + ((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..4c5f299c93 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowerSums.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 +-/ + +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`. +-/ + +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..8faa0bba96 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RationalityFromRecurrence.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 +-/ + +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₀`. +-/ + +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 [dif_pos (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 [dif_pos 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 + show (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. + letI := 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 := (d⁄dX ℂ).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..374ffc4134 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RecurrenceFromVanishing.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 +-/ + +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. +-/ + +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)) + show ρ ⟨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 + show ρ 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; show 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 + show 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] + show 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 -/ + +-- Raised budget: 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 + haveI : 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..aaf70c3f82 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/SubsetEH.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 +-/ + +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`. +-/ + +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))] + letI : 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 + show (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..d3c079a761 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/SuperPowerSums.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 +-/ + +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`. +-/ + +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 + show ∑ 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..f6e13d2a2a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/TCount.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTGuard +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`. +-/ + +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 [if_pos hτ, Finset.mul_sum] + refine Finset.sum_congr rfl fun σ _ => ?_ + by_cases hσ : ∀ i : Fin k, + 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) + · rw [if_pos ⟨hσ, hτ'⟩, if_pos 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 [if_neg (fun hc => hσ hc.1), if_neg hσ] + ring + · rw [if_neg hτ, mul_zero] + rw [Finset.sum_eq_zero fun σ _ => by + rw [if_neg (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..4c1db7688c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/TIdentity.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 +-/ + +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`. +-/ + +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 MvPolynomial.coeff (diagExp v - stairShift τ) + (∏ i, hSub (Finset.univ : Finset (Fin k)) + (((v i : ℤ) + ((σ i : Fin k) : ℕ) - + (i : ℕ)).toNat)) + else 0) + else 0)) = 1 := by + classical + have h1 : MvPolynomial.coeff (diagExp v) ((powMat v).det) = 1 := + alternant_coeff (fun i : Fin k => v i + ((k - 1) - (i : ℕ))) + hinj + have h2 : MvPolynomial.coeff (diagExp v) + ((jtMat v).det * (powMat (fun _ : Fin k => 0)).det) = 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 [if_pos hle, if_pos hle, coeff_det_jtMat] + · rw [if_neg hle, if_neg 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..97491aa613 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaExp.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 +-/ + +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. +-/ + +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, if_pos 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 : ℕ → ℂ) : + d⁄dX ℂ (psLog t) = powerSumSeries t := by + ext n + rw [coeff_derivative, psLog, coeff_mk, if_neg (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..0fcc058b61 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaRational.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 +-/ + +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. +-/ + +namespace RS + +open scoped Polynomial PowerSeries + +/-! ### Normalising both constant terms to 1 -/ + +-- Raised budget: 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..03ffe57eb8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaSeries.lean @@ -0,0 +1,83 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 : d⁄dX ℂ F = S * F) + (hG : d⁄dX ℂ 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 (d⁄dX ℂ F) = coeff n (S * F) := congr_arg (coeff n) hF + have hGn : coeff n (d⁄dX ℂ 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 : ℕ → ℂ) : + d⁄dX ℂ (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 : d⁄dX ℂ 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..16fe291f30 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common.lean @@ -0,0 +1,24 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Common.NilpotentMap +import LeanPool.RegtsSevenster.RS.Common.ListPairs +import LeanPool.RegtsSevenster.RS.Common.FinSlots +import LeanPool.RegtsSevenster.RS.Common.DiagramChain +import LeanPool.RegtsSevenster.RS.Common.ExponentialGrowth +import LeanPool.RegtsSevenster.RS.Common.FactorialBound +import LeanPool.RegtsSevenster.RS.Common.ListAttach +import LeanPool.RegtsSevenster.RS.Common.ListSign +import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +import LeanPool.RegtsSevenster.RS.Common.NilpotentPowerTrace +import LeanPool.RegtsSevenster.RS.Common.PairDisjoint +import LeanPool.RegtsSevenster.RS.Common.PermCongr +import LeanPool.RegtsSevenster.RS.Common.PermTopSplit +import LeanPool.RegtsSevenster.RS.Common.ProdSum +import LeanPool.RegtsSevenster.RS.Common.RowLenChain +import LeanPool.RegtsSevenster.RS.Common.RowSpanRank +import LeanPool.RegtsSevenster.RS.Common.TraceSeparation +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..85f193270a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/DiagramChain.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 +-/ + +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`. +-/ + +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 + show 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 + show (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..cc62eb00a6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/ExponentialGrowth.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 +-/ + +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. +-/ + +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 + convert (tendsto_const_nhds (x := (d : ℝ))).div + hpoly (by norm_num) using 1 + · rfl + · simp + 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..9fcac64292 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/FactorialBound.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 +-/ + +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`. +-/ + +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..41df74ff29 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/FinSlots.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 +-/ + +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. +-/ + +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..6e666749df --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/ListAttach.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 +-/ + +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. +-/ + +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..8d1ad77da3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/ListPairs.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 +-/ + +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. +-/ + +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 + +-- Raised budget: 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..68b31cc676 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/ListSign.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 +-/ + +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. +-/ + +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..228ca8103c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/MathlibDeps.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 +-/ + +import Mathlib.Algebra.Algebra.Subalgebra.Lattice +import Mathlib.Algebra.BigOperators.Fin +import Mathlib.Algebra.Category.FGModuleCat.Abelian +import Mathlib.Algebra.Category.ModuleCat.Biproducts +import Mathlib.Algebra.DirectSum.LinearMap +import Mathlib.Algebra.Group.Even +import Mathlib.Algebra.Homology.ShortComplex.ExactFunctor +import Mathlib.Algebra.Homology.ShortComplex.ShortExact +import Mathlib.Algebra.Module.PUnit +import Mathlib.Algebra.MonoidAlgebra.Basic +import Mathlib.Algebra.MonoidAlgebra.Module +import Mathlib.Analysis.Complex.Cardinality +import Mathlib.Analysis.Complex.Polynomial.Basic +import Mathlib.Analysis.SpecialFunctions.Exp +import Mathlib.CategoryTheory.Abelian.Basic +import Mathlib.CategoryTheory.Abelian.FunctorCategory +import Mathlib.CategoryTheory.Abelian.GrothendieckAxioms.Colim +import Mathlib.CategoryTheory.Abelian.GrothendieckAxioms.Indization +import Mathlib.CategoryTheory.Abelian.Indization +import Mathlib.CategoryTheory.Abelian.Transfer +import Mathlib.CategoryTheory.Filtered.Connected +import Mathlib.CategoryTheory.Functor.OfSequence +import Mathlib.CategoryTheory.Generator.Indization +import Mathlib.CategoryTheory.Idempotents.Biproducts +import Mathlib.CategoryTheory.Idempotents.Karoubi +import Mathlib.CategoryTheory.Limits.Indization.Category +import Mathlib.CategoryTheory.Limits.Shapes.Biproducts +import Mathlib.CategoryTheory.Limits.Shapes.End +import Mathlib.CategoryTheory.Linear.LinearFunctor +import Mathlib.CategoryTheory.Monoidal.Braided.Basic +import Mathlib.CategoryTheory.Monoidal.Braided.Opposite +import Mathlib.CategoryTheory.Monoidal.Braided.Transport +import Mathlib.CategoryTheory.Monoidal.Category +import Mathlib.CategoryTheory.Monoidal.Closed.Braided +import Mathlib.CategoryTheory.Monoidal.Closed.Types +import Mathlib.CategoryTheory.Monoidal.CommMon_ +import Mathlib.CategoryTheory.Monoidal.DayConvolution.Braided +import Mathlib.CategoryTheory.Monoidal.DayConvolution.DayFunctor +import Mathlib.CategoryTheory.Monoidal.Functor +import Mathlib.CategoryTheory.Monoidal.Linear +import Mathlib.CategoryTheory.Monoidal.Mod +import Mathlib.CategoryTheory.Monoidal.Mon +import Mathlib.CategoryTheory.Monoidal.Preadditive +import Mathlib.CategoryTheory.Monoidal.Rigid.Basic +import Mathlib.CategoryTheory.Monoidal.Rigid.Braided +import Mathlib.CategoryTheory.Monoidal.Subcategory +import Mathlib.CategoryTheory.Monoidal.Transport +import Mathlib.CategoryTheory.Preadditive.Mat +import Mathlib.CategoryTheory.Preadditive.Schur +import Mathlib.CategoryTheory.Simple +import Mathlib.CategoryTheory.Subobject.Lattice +import Mathlib.CategoryTheory.Subobject.Limits +import Mathlib.Combinatorics.Enumerative.Partition.Basic +import Mathlib.Combinatorics.Young.YoungDiagram +import Mathlib.Data.Complex.Basic +import Mathlib.Data.Fin.Embedding +import Mathlib.Data.Fin.Tuple.Sort +import Mathlib.Data.Finset.Card +import Mathlib.Data.Finset.Lattice.Basic +import Mathlib.Data.Finset.NoncommProd +import Mathlib.Data.Fintype.EquivFin +import Mathlib.Data.Fintype.Perm +import Mathlib.FieldTheory.IsAlgClosed.Basic +import Mathlib.GroupTheory.Perm.Cycle.Basic +import Mathlib.GroupTheory.Perm.Cycle.Type +import Mathlib.GroupTheory.Perm.Fin +import Mathlib.GroupTheory.Perm.ViaEmbedding +import Mathlib.LinearAlgebra.Basis.VectorSpace +import Mathlib.LinearAlgebra.BilinearForm.Basic +import Mathlib.LinearAlgebra.BilinearForm.Orthogonal +import Mathlib.LinearAlgebra.BilinearForm.Properties +import Mathlib.LinearAlgebra.Contraction +import Mathlib.LinearAlgebra.DFinsupp +import Mathlib.LinearAlgebra.Dimension.Constructions +import Mathlib.LinearAlgebra.Dimension.Finrank +import Mathlib.LinearAlgebra.Dimension.Free +import Mathlib.LinearAlgebra.Dimension.StrongRankCondition +import Mathlib.LinearAlgebra.Dual.Lemmas +import Mathlib.LinearAlgebra.Eigenspace.Basic +import Mathlib.LinearAlgebra.Eigenspace.Triangularizable +import Mathlib.LinearAlgebra.FiniteDimensional.Defs +import Mathlib.LinearAlgebra.FiniteDimensional.Lemmas +import Mathlib.LinearAlgebra.Isomorphisms +import Mathlib.LinearAlgebra.LinearIndependent.Lemmas +import Mathlib.LinearAlgebra.Matrix.Determinant.Basic +import Mathlib.LinearAlgebra.Matrix.NonsingularInverse +import Mathlib.LinearAlgebra.Matrix.Rank +import Mathlib.LinearAlgebra.Matrix.ToLin +import Mathlib.LinearAlgebra.Prod +import Mathlib.LinearAlgebra.Projection +import Mathlib.LinearAlgebra.QuadraticForm.Basic +import Mathlib.LinearAlgebra.TensorProduct.Associator +import Mathlib.LinearAlgebra.TensorProduct.Finiteness +import Mathlib.LinearAlgebra.TensorProduct.Prod +import Mathlib.LinearAlgebra.Trace +import Mathlib.LinearAlgebra.Vandermonde +import Mathlib.Logic.Equiv.Fin.Rotate +import Mathlib.Order.Zorn +import Mathlib.RepresentationTheory.Basic +import Mathlib.RepresentationTheory.Character +import Mathlib.RepresentationTheory.Irreducible +import Mathlib.RepresentationTheory.Maschke +import Mathlib.RingTheory.Algebraic.LinearIndependent +import Mathlib.RingTheory.Artinian.Module +import Mathlib.RingTheory.Artinian.Ring +import Mathlib.RingTheory.EuclideanDomain +import Mathlib.RingTheory.Finiteness.Prod +import Mathlib.RingTheory.Ideal.Quotient.Operations +import Mathlib.RingTheory.Idempotents +import Mathlib.RingTheory.Jacobson.Ring +import Mathlib.RingTheory.Jacobson.Semiprimary +import Mathlib.RingTheory.MvPolynomial.Symmetric.NewtonIdentities +import Mathlib.RingTheory.Polynomial.Vieta +import Mathlib.RingTheory.PowerSeries.Derivative +import Mathlib.RingTheory.PowerSeries.Exp +import Mathlib.RingTheory.PowerSeries.Inverse +import Mathlib.RingTheory.PowerSeries.Substitution +import Mathlib.RingTheory.SimpleModule.Basic +import Mathlib.RingTheory.SimpleModule.IsAlgClosed +import Mathlib.RingTheory.TensorProduct.Finite +import Mathlib.SetTheory.Cardinal.Order +import Mathlib.Tactic.CategoryTheory.Monoidal.Basic +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..2adf27e2a7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/NilpotentMap.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 +-/ + +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. +-/ + +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..5fee0f8fac --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/NilpotentPowerTrace.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 +-/ + +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). +-/ + +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..e6f2c83d3b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/PairDisjoint.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 +-/ + +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. +-/ + +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..95afef582e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/PermCongr.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 +-/ + +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. +-/ + +namespace RS + +open Equiv Equiv.Perm + +/-- `permCongr` is `extendDomain` along the trivial subtype. -/ +theorem permCongr_eq_extendDomain {α β : Type} [Fintype α] + [DecidableEq α] [Fintype β] [DecidableEq β] + (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} [Fintype α] + [DecidableEq α] [Fintype β] [DecidableEq β] + (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) + show 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 + show 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} + [DecidableEq α] [DecidableEq β] (τ : 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} + [DecidableEq α] [DecidableEq β] + (σ : 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..50f1bd7d13 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/PermTopSplit.lean @@ -0,0 +1,459 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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 σ (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 + show σ (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 + show σ (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 + show (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 + show (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 + show 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 + show σ (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] + show σ (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..b1fb03b97d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/ProdSum.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 +-/ + +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. +-/ + +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..8932abcf02 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/RowLenChain.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 +-/ + +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. +-/ + +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 [if_pos 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 [if_neg 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..7d9c6afefa --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/RowSpanRank.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 +-/ + +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. +-/ + +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 + haveI : 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 + haveI : 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..2fd592da80 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/TraceSeparation.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 +-/ + +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. +-/ + +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τ, if_neg (fun h => hne (inv_mul_eq_one.mp h)), + mul_zero] + · intro σ + change c⁻¹ * τ (ρ σ⁻¹ * ρ σ) = 1 + rw [← map_mul, inv_mul_cancel, hτ, if_pos 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..1fb5a35f0f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Common/YoungDiagrams.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 +-/ + +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. +-/ + +namespace RS + +/-- The `s × s` square Young diagram. -/ +def squareDiagram (s : ℕ) : YoungDiagram := + YoungDiagram.ofRowLens (List.replicate s s) <| by + intro i j _ + simp + +/-- 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..b5dfd49b0b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Definitions.lean @@ -0,0 +1,2504 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. -/ + +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 [ha] 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 [ha] 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 [dif_neg (by + rw [W.pairing_invol] + exact fun h => hbne h.symm)] + rw [dif_pos (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 [dif_pos (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 [dif_neg (by rw [W.pairing_invol]; exact fun h => f.prop.1 h)] + rw [dif_neg (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. -/ +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 + letI := W.flagOrder + letI := 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 + show 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.induction_on with + | zero => simp + | 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.induction_on with + | zero => simp + | 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.induction_on with + | zero => simp + | 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.induction_on with + | zero => simp + | 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 -/ + +/-- 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 {Y Z} f => 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.induction_on with + | zero => simp + | 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.induction_on with + | zero => simp + | 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.induction_on with + | zero => simp + | 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.induction_on with + | zero => simp + | tmul a b => simp [TensorProduct.comm_tmul, TensorProduct.map_tmul] + | add x₁ x₂ hx₁ hx₂ => simp only [map_add, hx₁, hx₂] + 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.induction_on with + | zero => simp + | 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.induction_on with + | zero => simp + | 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.induction_on with + | zero => simp + | 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.induction_on with + | zero => simp + | 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 + · show g.evenMap ∘ₗ (f.evenMap + f'.evenMap) = _ + exact LinearMap.comp_add _ _ _ + · show g.oddMap ∘ₗ (f.oddMap + f'.oddMap) = _ + exact LinearMap.comp_add _ _ _ + comp_add _ _ _ f g g' := by + apply Hom.ext + · show (g.evenMap + g'.evenMap) ∘ₗ f.evenMap = _ + exact LinearMap.add_comp _ _ _ + · show (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 + · show g.evenMap ∘ₗ (c • f.evenMap) = _ + exact LinearMap.comp_smul _ _ _ + · show g.oddMap ∘ₗ (c • f.oddMap) = _ + exact LinearMap.comp_smul _ _ _ + comp_smul _ _ _ f c g := by + apply Hom.ext + · show (c • g.evenMap) ∘ₗ f.evenMap = _ + exact LinearMap.smul_comp _ _ _ + · show (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 + haveI : 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..a50343df56 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/DimensionDefinitions.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 +-/ + +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. +-/ + +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..664b59f99d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Glossary.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 +-/ + +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..10552fc40b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairList +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjSwapBmc +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjacentWord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisCoord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisSplit +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaData +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiag +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiagForm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaFlip +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockCanon +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockOddList +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockParity +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockRestrict +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSigma +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSort +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BraidWord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonColour +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapClosed +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapExpansion +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapFun +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapMatch +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeel +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeelSplit +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapSplit +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapVal +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ChainLists +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleModel +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleScalar +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircuitCount +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ClosedTransition +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ConcatSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordInterface +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordOf +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoreParity +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EdgeSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvForm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvFormOdd +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvLeaf +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FibreParam +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FlagEnum +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.GlobalSlotList +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.HRS +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ListSignPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MasterSum +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelCoord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelStarVec +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MultiStar +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFDef +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFValue +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddFlip +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddListMultiset +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddPair +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddSignProd +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaCotensor +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTensor +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTransport +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OneBasis +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OrbitCard +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OutSignEdges +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairEnum +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ParameterModel +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PatternInv +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RegroupSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.Reindex +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexHeart +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexVanish +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RiffleSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SignPair +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SkeinPowBraid +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SlotPairing +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortFactor +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarClassFactor +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPeel +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarRepeat +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarSymm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarTensorClass +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StdTransport +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StrandTransport +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauCount +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TopBraidMerge +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TwoBasis +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue +import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomDichotomy +import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomicIdempotents +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockAssembly +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockBounds +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockCycle +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactor +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactorialTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockSplice +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockTower +import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleNormal +import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvAbelian +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDeligne +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDelignePackage +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGenerator +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGrowth +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvSemisimple +import LeanPool.RegtsSevenster.RS.Novel.Envelope.FactorialTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.Frobenius +import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement +import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinementSharp +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiEmbBraided +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiMonoidal +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiRigid +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiSemisimple +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatBraided +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatEmbMonoidal +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatMonoidal +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatRigid +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatSemisimple +import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentMatTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.ObjectTower +import LeanPool.RegtsSevenster.RS.Novel.Envelope.PermTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarPermTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleAll +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleEnd +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinDimBound +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SuperKill +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast +import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowHom +import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowSplit +import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZeta +import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZetaSharp +import LeanPool.RegtsSevenster.RS.Novel.Extraction.CircleValue +import LeanPool.RegtsSevenster.RS.Novel.Extraction.CoordIso +import LeanPool.RegtsSevenster.RS.Novel.Extraction.Coordinates +import LeanPool.RegtsSevenster.RS.Novel.Extraction.CopairUnique +import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate +import LeanPool.RegtsSevenster.RS.Novel.Extraction.SnakeTransport +import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdDuality +import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid +import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper +import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalAgreement +import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalIndependence +import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedNat +import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleClose +import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleMapClasses +import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleTensor +import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence +import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonTransport +import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonicalFrame +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChainAgreement +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordCount +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordParity +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordSwapParity +import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate +import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotateLeft +import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseUnion +import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedAgreement +import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedCutDispatch +import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedIdentify +import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedTopSum +import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourGlue +import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourRecursion +import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc +import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeNormal +import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeRelabel +import LeanPool.RegtsSevenster.RS.Novel.Skein.Composition +import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseAssembly +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseFamily +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseGram +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseIdentity +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseLift +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConversePair +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseTrip +import LeanPool.RegtsSevenster.RS.Novel.Skein.CrossingDelta +import LeanPool.RegtsSevenster.RS.Novel.Skein.CutMatching +import LeanPool.RegtsSevenster.RS.Novel.Skein.CutSubsetSum +import LeanPool.RegtsSevenster.RS.Novel.Skein.DirMatching +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjSubsetSplit +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.A +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.B +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.C +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionProduct +import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeColouring +import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeSum +import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeTerm +import LeanPool.RegtsSevenster.RS.Novel.Skein.Eulerian +import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.FibreValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.FlagGraph +import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignForm +import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignProduct +import LeanPool.RegtsSevenster.RS.Novel.Skein.FourLabelParity +import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv +import LeanPool.RegtsSevenster.RS.Novel.Skein.GenBoundaryStates +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueAmbient +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChord +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChords +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCircuitDelta +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueComm +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueLedger +import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueRelTransport +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplit +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.A +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.C +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSubsetBij +import LeanPool.RegtsSevenster.RS.Novel.Skein.GramRank +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomCompose +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomSpaces +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceCyclic +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate +import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw +import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceAlternate +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceContract +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceCut +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceOrderIso +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceShift +import LeanPool.RegtsSevenster.RS.Novel.Skein.InvolutionCard +import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerCast +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerRecursion +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerSets +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerStage +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopExample +import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopVerify +import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition +import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalNat +import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalStruct +import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity +import LeanPool.RegtsSevenster.RS.Novel.Skein.NonSeparatedStep +import LeanPool.RegtsSevenster.RS.Novel.Skein.OpenCircuits +import LeanPool.RegtsSevenster.RS.Novel.Skein.OrbitParities +import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientExistence +import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientationFlip +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairCloseComm +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairedAssembly +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSwap +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialClose +import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseCompose +import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseTensor +import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon +import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger +import LeanPool.RegtsSevenster.RS.Novel.Skein.PathMatch +import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose +import LeanPool.RegtsSevenster.RS.Novel.Skein.PermFragment +import LeanPool.RegtsSevenster.RS.Novel.Skein.PropThreeOpen +import LeanPool.RegtsSevenster.RS.Novel.Skein.RSTensor +import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition +import LeanPool.RegtsSevenster.RS.Novel.Skein.RelValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelChords +import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelInvariance +import LeanPool.RegtsSevenster.RS.Novel.Skein.RepairInvariance +import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidityClasses +import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarClass +import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarFunctional +import LeanPool.RegtsSevenster.RS.Novel.Skein.SeparatedParity +import LeanPool.RegtsSevenster.RS.Novel.Skein.SimpleUnit +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCategory +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdealLeft +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinLinear +import LeanPool.RegtsSevenster.RS.Novel.Skein.SnakeClasses +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarCompClass +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarDecomposition +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarEnum +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarExplode +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarPrep +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarTrace +import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet +import LeanPool.RegtsSevenster.RS.Novel.Skein.StatusSet +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepFrame +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatus +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatusNonsep +import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle +import LeanPool.RegtsSevenster.RS.Novel.Skein.SumLexOrder +import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperGram +import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperSpace +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorAssoc +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorComm +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorCompClass +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorInterchange +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorUnit +import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut +import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughIndCFalse +import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue +import LeanPool.RegtsSevenster.RS.Novel.Skein.Trace +import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic +import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceNondegenerate +import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists +import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionMove +import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger +import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathNonSep +import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathStep +import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexOddSign +import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexSum +import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourEmbedding +import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourPadding +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..0eeca930f3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjSwapBmc.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SkeinPowBraid +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. +-/ + +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 [if_pos h1, if_pos (by rw [h1])] + · rw [if_neg h1, if_neg (fun hv => h1 (Fin.ext hv))] + by_cases h2 : x = b + · rw [if_pos h2, if_pos (by rw [h2])] + · rw [if_neg h2, if_neg (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] + show x.val = _ + rw [if_neg (show ¬ (x.val = n) by omega), + if_neg (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 show 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) _ _] + show n + (1 + 0) = _ + rw [if_pos hv] + · conv_lhs => rw [show x = Fin.natAdd n ⟨1, by omega⟩ from + Fin.ext (by show 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) _ _] + show n + 0 = _ + rw [if_neg (show ¬ (x.val = n) by omega), if_pos 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] + show ((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 show x.val = n + 1 + 0; omega), + tensorMapEquiv_natAdd] + show n + 1 + 0 = _ + rw [if_neg (show ¬ (x.val = i) by omega), + if_neg (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 dif_pos hi] + show 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 + dif_neg hi] + rw [skeinPowBraid_bmc (n + 1) i hle] + show 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..3015d4f0aa --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjacentWord.lean @@ -0,0 +1,188 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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`) -/ +private 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`. -/ +private 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..2f6714524a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisCoord.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordOf +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. +-/ + +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 [dif_pos 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 [if_pos rfl] + exact Pi.single_eq_same _ _ + · rw [if_neg he] + exact Pi.single_eq_of_ne + (fun h => he (congrArg Subtype.val h)) _ + · rw [coordOf_odd _ _ hc'] + rw [if_neg (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..ed39de9d0e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisSplit.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 +-/ + +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. +-/ + +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) + +-- Raised budget: 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 [dif_pos 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 [dif_pos 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 [dif_neg h'] + have hne : c' ≠ c := fun he => h' (he ▸ h) + rw [single_val_ne ⟨c, hc⟩ ⟨c', hc'⟩ hne] + · rw [dif_neg 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 [dif_pos h'] + have hne : c' ≠ c := fun he => h (he ▸ h') + rw [single_val_ne ⟨c, hc⟩ ⟨c', hc'⟩ hne] + · rw [dif_neg 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..1537d55b1f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaData.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 +-/ + +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. +-/ + +namespace RS + +open Classical 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 [dif_pos h, if_pos h] + show (if u.val + ℓ = u.val + ℓ then (1 : ℂ) + else if (u.val + ℓ) + ℓ = u.val then -1 else 0) = + -((-1 : ℤ) : ℂ) + rw [if_pos rfl] + simp + · rw [dif_neg h, if_neg h] + show (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 [if_neg h1, if_pos (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 [dif_pos h, dif_pos h, if_pos hslot] + · rw [dif_neg h, dif_neg 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 [dif_pos h, dif_pos h, if_neg hslot] + · rw [dif_neg h, dif_neg h] + rw [key (Fin.natAdd (edgeCount W) i) + (show ¬ (Fin.natAdd (edgeCount W) i).val < edgeCount W from by + show ¬ (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 [dif_pos h', dif_pos 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 [dif_neg h', dif_neg 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 +-- Raised budget: 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 + show 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 [dif_pos h, dif_pos h, dif_pos h] + exact colourFormEntry_inr_partner _ + · rw [dif_neg h, dif_neg h, dif_neg h] + show (if (ψ.val ⟨_, h⟩) = (ψ.val ⟨_, h⟩) then (1 : ℂ) else 0) = 1 + rw [if_pos 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..798d804511 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiag.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeelSplit +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. +-/ + +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 + show 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 + show 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 ?_) + show capPeelInv m j.val = j.val + unfold capPeelInv + rw [if_pos 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 ?_) + show capPeelInv m ((m + m) + 1) = (m + 1) + m + unfold capPeelInv + rw [if_neg (by omega), if_neg (by omega), if_neg (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..42ae066a4b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiagForm.lean @@ -0,0 +1,537 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiag +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`. +-/ + +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 + show 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 + show peelColour m c ⟨m + j.val, by omega⟩ = + c ⟨(m + 1) + j.val, by omega⟩ + rw [peelColour_apply] + refine congrArg c (Fin.ext ?_) + show 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 + show peelColour m c ⟨(m + m) + 0, by omega⟩ = c ⟨m, by omega⟩ + rw [peelColour_apply] + refine congrArg c (Fin.ext ?_) + show 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 + show 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 + show 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⟩ + · show 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]; show (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, ?_, ?_, ?_⟩ + · show (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 -/ + +-- Raised budget: 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 [dif_pos 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..29fab0ea04 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaFlip.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaData +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EdgeSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddSignProd +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OutSignEdges +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. +-/ + +namespace RS + +open Classical 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..cef628f67e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockAlign.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag +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. +-/ + +namespace RS + +open Classical 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 [if_pos 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, if_pos 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, if_neg hout] + · rw [if_neg 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, if_pos 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, + if_neg 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..fd4900fa3e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockCanon.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonPerm +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign +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. +-/ + +namespace RS + +open Classical 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] + +-- Raised budget: 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 + · show 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⟩ + show 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 + · show 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 + show 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..cc8ed14254 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockData.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 +-/ + +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. +-/ + +namespace RS + +open Classical 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) + +/-- **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 + show (Fintype.equivFin W.Vertex) + (starAssign W (starFlagEnum W g)) = _ + have hv : starAssign W (starFlagEnum W g) = + blockVertex W v := by + show 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, ?_⟩ + show (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, dif_neg 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, dif_pos 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 + +-- Raised budget: 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..180d9e93f8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockOddList.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue +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. +-/ + +namespace RS + +open Classical Finset + +variable {k ℓ : ℕ} + +-- Raised budget: 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..e0c9e5a8f1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockParity.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 +-/ + +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. +-/ + +namespace RS + +open Classical 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) + show 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 + show (sortEquiv (starAssignEnum W)).symm + (blockSigmaEquiv (ds W) ⟨v, jw⟩) = s + have hbe : blockSigmaEquiv (ds W) ⟨v, jw⟩ = + sortEquiv (starAssignEnum W) s := by + show 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] + +/-- **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 + show (Fintype.equivFin W.Vertex) (starAssign W s) = _ + have hv : starAssign W s = blockVertex W v := by + show 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] + +/-- **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..cee0e9a119 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockRestrict.lean @@ -0,0 +1,83 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord +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. +-/ + +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 + show 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 + show 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..61aba9a3cd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSigma.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 +-/ + +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. +-/ + +namespace RS + +/-- Split the sigma over a cons list into head + tail. -/ +private 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. -/ +private 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. -/ +private 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 + show 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 [dif_pos hlt] + | v + 1 => + -- p = ⟨⟨v+1, hv⟩, j⟩ where j : Fin (ds.get ⟨v, _⟩) + show 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 [dif_neg 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..31796fb1c8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSort.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 +-/ + +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. +-/ + +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 + · show Sum.inl (b (σ i)) = + (Sum.inl (assign i) : V ⊕ Fin n).map e id + rw [hb i] + rfl + · show 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..d5b27173d7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BraidWord.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 +-/ + +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. +-/ + +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 + letI := 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] + show 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 + letI := 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..a6d6d28381 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonColour.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 +-/ + +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. +-/ + +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 [dif_pos 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 [dif_neg 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..1ee67ed3c0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij +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. +-/ + +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 [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 => + show 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 => + show 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 => + show 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 + +-- Raised budget: 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 + show 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 (Fin.mk_le_mk.mpr (by omega) : + (⟨i, hlen ▸ h1⟩ : Fin _) ≤ ⟨j, hlen ▸ h2⟩) + · -- left ≤ right + show 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 + show 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 (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 [dif_pos hfin, List.getElem_append_left (by omega)] + simp [List.getElem_map] + · have hfin : ¬ (finCongr h ⟨i, hi1⟩).val < μm.card := by simp [hlt] + rw [dif_neg 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 + · show 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 + show (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 + show 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; show (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 + show 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 show a.val + 1 < b.val + 1; omega) + show (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 + show 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; show (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 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 + · show p₁.val - m < p₂.val - m; omega + · have he1 : g ⟨p₁.val - m, by omega⟩ = σ p₁ := by + show σ ⟨m + (p₁.val - m), _⟩ = σ p₁ + congr 1; apply Fin.ext; show m + (p₁.val - m) = p₁.val; omega + have he2 : g ⟨p₂.val - m, by omega⟩ = σ p₂ := by + show σ ⟨m + (p₂.val - m), _⟩ = σ p₂ + congr 1; apply Fin.ext; show 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 show a₁.val = a₂.val; omega)) + (Fin.ext (by show 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 show 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 [dif_neg hge] + simp only [Sum.getRight?_inr, Option.some.injEq] + show (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 + show σ ⟨m + ((σ.symm q).val - m), _⟩ = q + rw [show (⟨m + ((σ.symm q).val - m), _⟩ : Fin d) = σ.symm q from + Fin.ext (by show 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 [dif_pos (by simp [finCongr_apply]; exact hq_low)] + exact Sum.getRight?_inl + -- Step 3c: structural claim + have step3 : oddListOf c = List.ofFn (v ∘ π) := by + show (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 (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 -/ + +-- Raised budget: 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..5a7e68f09d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapClosed.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord +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. +-/ + +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 ℓ : ℕ} + +-- Raised budget: 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 + letI := 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 [if_neg (fun hspec => hb + (Subtype.ext (eq_peelColour_of m hspec)))] + rw [mul_zero, zero_mul] + · intro habs + exact absurd (Finset.mem_univ _) habs + · rw [if_pos (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 [dif_pos 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), dif_pos 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 [dif_neg 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), dif_neg 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..28b1b78b16 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapExpansion.lean @@ -0,0 +1,40 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 [dif_pos 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..59617f9035 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapFun.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeel +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. +-/ + +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 + letI := P.braided + rw [bundleCapClass_zero] + show ((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..8d997c4c5e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapMatch.lean @@ -0,0 +1,37 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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..79738892de --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeel.lean @@ -0,0 +1,419 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show capPeelInv m (capPeelFun m i.val) = i.val + unfold capPeelFun capPeelInv + split_ifs <;> omega) + right_inv j := Fin.ext (by + have := j.isLt + show 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 [dif_pos h] + show (⟨i.val, _⟩, b) = (i, b) + exact Prod.ext (Fin.ext rfl) rfl + · rw [dif_neg h] + have hi : i.val = m := by + have := i.isLt + omega + cases b + · show ((⟨m, _⟩ : Fin (m + 1)), + decide ((0 : Fin 2).val = 1)) = (i, false) + exact Prod.ext (Fin.ext (show m = i.val by omega)) rfl + · show ((⟨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 + · show capPeelFlagFun m (⟨j.val, _⟩, b) = _ + unfold capPeelFlagFun + rw [dif_pos (show (⟨j.val, by omega⟩ : + Fin (m + 1)).val < m from j.isLt)] + · show capPeelFlagFun m (⟨m, _⟩, decide (t.val = 1)) = _ + unfold capPeelFlagFun + rw [dif_neg (show ¬ ((⟨m, by omega⟩ : + Fin (m + 1)).val < m) from by + show ¬ (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 + +/-- **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 := fun g => 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) := dif_pos 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 + · show 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] + show capPeelInv m i.val = i.val + unfold capPeelInv + rw [if_pos h] + · show 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] + show 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 + show capPeelFlagFun m (i, false) = _ + unfold capPeelFlagFun + rw [dif_neg 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) ?_ + show 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] + show capPeelInv m ((m + m) + 0) = i.val + unfold capPeelInv + split_ifs <;> omega + · have hflag : capPeelFlagEquiv m (i, true) = + Sum.inr 1 := by + show capPeelFlagFun m (i, true) = _ + unfold capPeelFlagFun + rw [dif_neg 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) ?_ + show 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] + show capPeelInv m ((m + m) + 1) = (m + 1) + i.val + unfold capPeelInv + split_ifs <;> omega + -- ═══════ PAIRING ═══════ + pairing_comm := fun g => by + obtain ⟨i, b⟩ := g + show 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 ((dif_pos 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))) + (dif_pos 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 + show capPeelFlagFun m (i, false) = _ + unfold capPeelFlagFun + rw [dif_neg h] + rfl + have ht : capPeelFlagEquiv m (i, true) = + Sum.inr (1 : Fin 2) := by + show capPeelFlagFun m (i, true) = _ + unfold capPeelFlagFun + rw [dif_neg 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)) + 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..34c87fa66b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeelSplit.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 +-/ + +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. +-/ + +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 [dif_pos 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 + +-- Raised budget: 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 + letI := 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) ?_ + show 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) _ _ + +-- Raised budget: 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 + letI := 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..a08fc597e2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPerm.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 +-/ + +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. +-/ + +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 + letI := 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..fb8a1d60b3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapSplit.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 +-/ + +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. +-/ + +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)) + +-- Raised budget: 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 + letI := 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) ?_ + show 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..79802f1abe --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapVal.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 +-/ + +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. +-/ + +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 + letI := 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..0d4d17a310 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ChainLists.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 +-/ + +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. +-/ + +namespace RS + +open Classical 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..e7e922fad4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleModel.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StdTransport +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ℓ`. +-/ + +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 + show 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)) + +-- Raised budget: 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 + letI := 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.ω] + show 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..725f761ac6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleScalar.lean @@ -0,0 +1,173 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MultiStar +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. +-/ + +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 + · show (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 + haveI h1 : IsEmpty (circlesClosed a).Flag := + inferInstanceAs (IsEmpty Empty) + haveI h2 : IsEmpty (circlesClosed b).Flag := + inferInstanceAs (IsEmpty Empty) + exact g.elim h1.elim h2.elim + pairing_comm := fun g => by + haveI h1 : IsEmpty (circlesClosed a).Flag := + inferInstanceAs (IsEmpty Empty) + haveI 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 + haveI : IsEmpty (circlesClosed 0).Flag := + inferInstanceAs (IsEmpty Empty) + exact isEmptyElim g + pairing_comm := fun g => by + haveI : 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..3ee81a952b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircuitCount.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 +-/ + +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. +-/ + +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 => κ.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..a4becd46b0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ClosedTransition.lean @@ -0,0 +1,37 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockRestrict +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. +-/ + +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..e1b18f1f8d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ConcatSign.lean @@ -0,0 +1,220 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +open Classical 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 + 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 + show 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..a313e3b82b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordInterface.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 +-/ + +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. +-/ + +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 + letI := 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..6bc526a711 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordOf.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ParameterModel +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. +-/ + +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 := + dif_neg 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 + show (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..f8076d739a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoreParity.lean @@ -0,0 +1,355 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaFlip +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauCount +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ConcatSign +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SignPair +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RiffleSign +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. +-/ + +namespace RS + +open CategoryTheory MonoidalCategory Finset +open Functor.LaxMonoidal Functor.OplaxMonoidal +open Classical + +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 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 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 nB + 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 + -- ═══════ 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] + +-- Raised budget: 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..fd06f26745 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EdgeSign.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag +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. +-/ + +namespace RS + +open Classical 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 [dif_pos h, dif_pos 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 [if_neg (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 [if_pos ⟨h, hof⟩] + ring + · rw [dif_neg h, dif_neg h, + if_neg (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..7cada6867e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvForm.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 +-/ + +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. +-/ + +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 + letI := 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 + show 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..c1eadd4a11 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvFormOdd.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisSplit +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. +-/ + +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 + letI := 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 + show 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..ced44ed342 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvLeaf.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 +-/ + +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. +-/ + +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 + show 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 + show 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 + +-- Raised budget: 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 + letI := 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, dif_pos 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) ?_ + show 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, dif_neg 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) ?_ + show 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..0dc16f9d2c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FibreParam.lean @@ -0,0 +1,609 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +open CategoryTheory Finset +open Classical + +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 [dif_neg 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 [dif_pos (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 [dif_pos h, dif_pos h'] + rw [if_pos (show (Fin.castAdd (edgeCount W) i).val < + edgeCount W from i.isLt)] + rw [if_neg (show ¬ ((Fin.natAdd (edgeCount W) i).val < + edgeCount W) from by + show ¬ (edgeCount W + i.val < edgeCount W); omega)] + show 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 [dif_neg h, dif_neg h'] + show 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 + show 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 [if_pos hlow] + rw [if_neg (show ¬ ((starFlagEnum W + (W.pairing g)).val < edgeCount W) from by + rw [starFlagEnum_pairing_low W g hlow] + show ¬ (edgeCount W + (starFlagEnum W g).val < + edgeCount W) + omega)] + exact getRight_congr (congrArg c (congrArg _ + (W.pairing_invol g))) _ _ + · rw [if_neg hlow] + rw [if_pos (show (starFlagEnum W + (W.pairing g)).val < edgeCount W from by + rw [starFlagEnum_pairing_high W g hlow] + show (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] + show (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⟩ + +-- Raised budget: 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 [dif_pos 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 [if_pos hrep] + show Sum.inr (oddDataOf W F c hfibre + ⟨(starFlagEnum W).symm slot, h⟩) = c slot + rw [oddDataOf] + rw [if_pos (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 [if_neg hrep] + show Sum.inr (oddPartner ℓ (oddDataOf W F c hfibre + ⟨(starFlagEnum W).symm slot, h⟩)) = c slot + rw [oddDataOf] + rw [if_neg (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 ?_ + show (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 + show 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 [dif_neg 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 + show 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 [if_pos hlow] + have hval : colouringOf W F ψ φ (starFlagEnum W g) = + Sum.inr (φ.val ⟨g, hg⟩) := by + rw [colouringOf] + rw [dif_pos (show (starFlagEnum W).symm + (starFlagEnum W g) ∈ F.flags from by + rw [_root_.Equiv.symm_apply_apply]; exact hg)] + rw [if_pos 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 [if_neg hlow] + have hglow : (starFlagEnum W + (W.pairing g)).val < edgeCount W := by + rw [starFlagEnum_pairing_high W g hlow] + show (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 [dif_pos (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 [if_pos 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 [dif_neg (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..57ca6b9295 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FlagEnum.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairEnum +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. +-/ + +namespace RS + +open Classical 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 + letI := W.flagOrder + letI := 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) ?_ + letI := W.flagOrder + letI := 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 + show 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 ?_ + show 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..602310a1ab --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/GlobalSlotList.lean @@ -0,0 +1,525 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey +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. +-/ + +namespace RS + +open Classical 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} [DecidableEq β] + {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 β] + [DecidableEq β] {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 + 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.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 + show ((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 + show ((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..660065d192 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/HRS.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonColour +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 `Ψ`. +-/ + +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 := + dif_neg 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 [if_pos 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..350619b4a1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/IndexPerm.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 +-/ + +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. +-/ + +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*} [DecidableEq γ] (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 + show τ₁₃ 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..8a7b64be71 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ListSignPerm.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjacentWord +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`. +-/ + +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..3522a2ceb4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MasterSum.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 +-/ + +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. +-/ + +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 ℓ) + +-- Raised budget: 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..318019c4a8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelCoord.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMerge +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ClosedTransition +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. +-/ + +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 ℓ) + +-- Raised budget: 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 + haveI : 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 [dif_pos 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 [dif_pos 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 [dif_pos 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 [dif_pos 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 [dif_pos (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 [dif_neg 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..43b68efe72 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelPermCoord.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Super.ColourAction +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. +-/ + +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 => + show _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 [dif_pos 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 [dif_pos (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..092c02ccdf --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelStarVec.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 +-/ + +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. +-/ + +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))) + +-- Raised budget: 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 + letI := 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 + letI := 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. + show (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..1728dd702a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MultiStar.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 +-/ + +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. +-/ + +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 + · show 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 ?_ + show ClosedFragment.vertexOf W + ((starFlagEnum W).symm (starFlagEnum W fo)) = _ + rw [(starFlagEnum W).symm_apply_apply] + rfl + · show 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⟩ := + dif_pos (Finset.mem_univ fo) + rw [hp] + show Sum.inr (starEnum W ⟨fo, Finset.mem_univ fo⟩) = + Sum.inr (starFlagEnum W fo) + rfl + · show 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..9f79395b29 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFDef.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +open Classical Finset + +variable {k ℓ : ℕ} + +/-! ## The h-generic master summand -/ + +-- Raised budget: 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 -/ + +-- Raised budget: 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 [if_pos hnd_b] + rw [evenMultisetOf_blockRestrict W F o ψ φ v] + rw [oddFinsetOf_blockRestrict W F o ψ φ v] + rw [MixedFunctional.evalOdd, if_pos 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 if_neg 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..8601b001ff --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFValue.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoreParity +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. +-/ + +namespace RS + +open Classical Finset + +variable {k ℓ : ℕ} + +/-! ## The h-generic value identity -/ + +-- Raised budget: 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, dif_pos 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..07bc2c37f8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddFlip.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 +-/ + +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. +-/ + +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 + show (if f.val ∈ T then oddPartner ℓ (φ.val f) else φ.val f) = _ + exact if_pos 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 + show (if f.val ∈ T then oddPartner ℓ (φ.val f) else φ.val f) = _ + exact if_neg 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..2119f0034f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddListMultiset.lean @@ -0,0 +1,275 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +open Finset Classical + +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 -/ + +/-- 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 + letI := W.flagOrder + letI := 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⟩ + +/-- 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 -/ + +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 -/ + +/-- 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⟩) + show (↑(F.oddPairFn κ φ ⟨f, hf⟩) : Multiset _) = ({a} : Multiset _) + {b} + show (↑([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..8902234f0c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddPair.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 +-/ + +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. +-/ + +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 + show (SuperVect.tensorHom g h).evenMap (oddPair v w) = _ + show ((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 + show (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)) + +-- Raised budget: 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 + letI := 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 + · show ((((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 + show (((λ_ (𝟙_ 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..fc88e5641e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists + +/-! +# Product of odd signs over vertices equals product over outgoing flags +-/ + +namespace RS + +open Finset Classical + +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 dif_pos 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 + +/-- `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 + letI := 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 -/ + +/-- 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 + 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 [dif_neg 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 + · 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..ccf6c7b9a5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaCotensor.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 +-/ + +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. +-/ + +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 + show ((λ_ (𝟙_ 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] + show (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 _ _ + +-- Raised budget: 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 + letI := 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 + · show ((((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 + letI := P.braided + show ((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..1587b9c62c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaStarVec.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 +-/ + +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. +-/ + +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 + letI := 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..22224da377 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.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 +-/ + +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. +-/ + +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 + show 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 + letI := P.braided + show ((ε 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 + letI := P.braided + show ((ε 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 + show (SuperVect.tensorHom g h).evenMap (evenPair v w) = _ + show ((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 + show (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 + +-- Raised budget: 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) : + letI := P.braided + omegaVec f P (p ⊗ₘ q) = + ((μ P.ω (SkeinObj.mk a) (SkeinObj.mk b)) : + SuperVect.Hom _ _).evenMap + (evenPair (omegaVec f P p) (omegaVec f P q)) := by + letI := 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 ?_ + show ((μ 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..0d46b9f434 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTransport.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarCompClass +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinLinear +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneBridge +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. +-/ + +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 + letI := 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 + letI := 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] + show 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 + letI := 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..af4c1813ea --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OneBasis.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 +-/ + +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. +-/ + +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] + +-- Raised budget: 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'⟩ + show _ = ((colourPowerEquiv k ℓ 1).evenEquiv + (evenPair (1 : ℂ) (stdE k i)) ⟨c', hc'⟩) + show _ = (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] + show _ = 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'⟩ + show _ = ((colourPowerEquiv k ℓ 1).oddEquiv + (oddUnitPad (stdF ℓ a)) ⟨c', hc'⟩) + show _ = (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] + show _ = 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..8413e37b78 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OrbitCard.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 +-/ + +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. +-/ + +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 [Fintype β] (π : Perm β) : Finite (Orbits π) := 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 [dif_pos hx, dif_pos (eq_of_sameCycle_of_fixed hx h ▸ hx)] + exact congrArg Sum.inr + (Subtype.ext (eq_of_sameCycle_of_fixed hx h).symm) + · rw [dif_neg hx, dif_neg (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 => ?_) + show (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 [dif_pos hx] + · rw [dif_neg 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 + show orbitName π y = Sum.inl ⟨c, hc⟩ + unfold orbitName + rw [dif_neg hyne] + exact congrArg Sum.inl (Subtype.ext hyc) + · have hx' : π x = x := hx + show orbitName π x = Sum.inr ⟨x, hx⟩ + unfold orbitName + rw [dif_pos 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..764c8d1fef --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OutSignEdges.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 +-/ + +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. +-/ + +namespace RS + +open Classical 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 := + dif_pos hx + +private theorem outSignFun_of_not_mem {x : W.Flag} (hx : x ∉ F.flags) : + outSignFun W F o φ x = 1 := + dif_neg 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₁, dif_pos hmem] + by_cases hb : o.isOut f₀ = true + · -- f₀ outgoing, f₁ incoming + have hb₁ : ¬ o.isOut f₁ = true := by + rw [hflip, hb]; decide + rw [if_pos hb, if_neg 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 [if_neg hb, if_pos 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₁, + dif_neg 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..c5b3bae0d3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairEnum.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 +-/ + +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. +-/ + +namespace RS + +open Classical 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 + letI := W.flagOrder + letI := 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 [if_neg 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, if_pos hout] + show 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..bbeeae5e9f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairList.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ChainLists +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. +-/ + +namespace RS + +open Classical 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 show 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 [if_pos 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 [if_neg 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 [if_pos 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 [if_neg 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 [if_pos 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 [if_neg 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..b33498c2b5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ParameterModel.lean @@ -0,0 +1,152 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + letI := 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 _] + show 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 σ + +-- Raised budget: 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 + letI := 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..c79535c6e1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PatternInv.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 +-/ + +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. +-/ + +namespace RS + +open Classical 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..3a707d66d5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PowMerge.lean @@ -0,0 +1,188 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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)) + +-- Raised budget: 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 + letI := P.braided + -- The skein right unitor at `a` is the identity. + have hρ : (ρ_ (SkeinObj.mk a : SkeinObj f)).hom = + 𝟙 (SkeinObj.mk a) := by + show 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 + show (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 + letI := P.braided + -- Expand the right transport one step. + show (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 + show 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..504250a8dd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.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 +-/ + +import LeanPool.RegtsSevenster.RS.Common.ListPairs +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairList +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. +-/ + +namespace RS + +open Classical 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 [if_pos 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 [if_neg 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 [if_pos 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 [if_neg 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 [if_pos 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 [if_neg 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 + show 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 [if_neg 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 + show 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 show 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 [if_pos 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 + show 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 [if_neg 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 show 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 [if_pos 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 -/ + +-- Raised budget: 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 [if_pos ho] + have := o.pairing_flip _ (repMem_of_partEdge e.prop) + rw [pairing_starFlagEnum_symm] at this + rw [this, ho]; rfl + · rw [if_neg 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 [if_pos ho₁, if_pos ho₂] at hv + exact Fin.natAdd_injective _ _ ((starFlagEnum W).symm.injective hv) + · rw [if_pos ho₁, if_neg ho₂] at hv + exact absurd (congrArg Fin.val ((starFlagEnum W).symm.injective hv)) + (by simp [Fin.val_castAdd]; omega) + · rw [if_neg ho₁, if_pos ho₂] at hv + exact absurd (congrArg Fin.val ((starFlagEnum W).symm.injective hv)) + (by simp [Fin.val_castAdd]; omega) + · rw [if_neg ho₁, if_neg 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 -/ + +-- Raised budget: the index permutation between the two lists is +-- computed position by position, so both flat-map presentations +-- and the out-permutation unfold together. +/-- **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⟩) + (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 + intro k hk + apply Subtype.ext + rw [EdgeSubset.TransitionSystem.walkPerm_val] + show κ.match_ (W.pairing (W.pairing (mB[k]'hk).val)) = κ.match_ + (mB[k]'hk).val + congr 1 + exact W.pairing_invol _ + -- 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) (globalPairList_nodup' W F o) + (fun x => ⟨fun _ => mem_globalPairList' W F o x, + fun _ => mem_matchedPairList' W F o x⟩) + (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 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 + show 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..99404e8797 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/Reindex.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarRepeat +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SlotPairing +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. +-/ + +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..1e6e6511f4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexBij.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 +-/ + +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. +-/ + +namespace RS + +open CategoryTheory Finset +open Classical + +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 + +-- Raised budget: 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 + 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..c5ae6f90c7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexHeart.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFValue +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. +-/ + +namespace RS + +open CategoryTheory MonoidalCategory Finset +open Functor.LaxMonoidal Functor.OplaxMonoidal +open Classical + +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 ℓ) + +-- Raised budget: 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 + +/-- **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 [dif_pos hc] + by_cases hE : (EdgeSubset.mk s hc).Eulerian + · rw [if_pos 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 [if_neg 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 [dif_neg 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 + 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..cc5c4e5d06 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexVanish.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockParity +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiagForm +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. +-/ + +namespace RS + +open CategoryTheory Finset +open Classical + +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, if_neg h] + +-- Raised budget: 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) ?_ + show 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 [if_neg (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..3b9720101e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RepFlag.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 +-/ + +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. +-/ + +namespace RS + +open Classical 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 := if_pos 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 := if_neg 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] + show ¬ edgeCount W + _ < edgeCount W + omega + rw [repFlag, if_neg 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] + show (starFlagEnum W g).val - edgeCount W < edgeCount W + omega + rw [repFlag, if_pos 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..93265b6d9d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RiffleSign.lean @@ -0,0 +1,672 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairList +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. +-/ + +namespace RS + +open Classical 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 + show (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 + show (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 + show (([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 + show (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) + show ((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*} [DecidableEq α] + [LinearOrder α] (S : Finset α) : + ((S ×ˢ S).filter (fun p => p.1 < p.2)).card = + Nat.choose S.card 2 := by + 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 + show (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 [if_pos hsw]; exact List.Perm.swap _ _ _ + · rw [if_neg 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 [if_pos hsw_e] + simp only [List.cons_append, List.nil_append] + -- inversions (natAdd :: castAdd :: rest_fm) + show ((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 + show (Fin.castAdd n e).val < (Fin.natAdd n e).val + simp only [Fin.val_castAdd, Fin.val_natAdd]; omega + rw [List.filter_cons, if_pos (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, if_pos hsw_e, List.length_cons] + simp only [show Nat.succ 1 = 2 from rfl]; omega + · -- Not swapped: [castAdd e, natAdd e] ++ rest_fm + rw [if_neg hsw_e] + simp only [List.cons_append, List.nil_append] + -- inversions (castAdd :: natAdd :: rest_fm) + show ((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, if_neg (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, if_neg 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..b7ba66e10f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SignPair.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm +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. +-/ + +namespace RS + +open Classical + +/-- **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..7364059b12 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SkeinPowBraid.lean @@ -0,0 +1,205 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StdTransport +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. +-/ + +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 + show 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 + show 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)) + +-- Raised budget: 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 + letI := 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 dif_pos hi] + rw [show powBraid (stdSuperPair k ℓ) (n + 2) i h = + topBraid (stdSuperPair k ℓ) n from dif_pos 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 + dif_neg hi] + rw [show powBraid (stdSuperPair k ℓ) (n + 2) i h = + (powBraid (stdSuperPair k ℓ) (n + 1) i hle) ▷ + stdSuperPair k ℓ from dif_neg hi] + show ((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..4e21c6a306 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SlotPairing.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 +-/ + +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. +-/ + +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..5beff62eb5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortFactor.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSigma +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. +-/ + +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 + show 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..b240e897d4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortPerm.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 +-/ + +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. +-/ + +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..11367e03e5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarClassFactor.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 +-/ + +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. +-/ + +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 ?_) + show (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] + show 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..c9df004a63 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPeel.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 +-/ + +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. +-/ + +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 + show 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 () := dif_pos h + rw [h1] + exact Fin.ext h.symm + · have h1 : peelVertexFun n v = + Sum.inr ⟨v.val - 1, by have := v.isLt; omega⟩ := + dif_neg h + rw [h1] + exact Fin.ext (by + show v.val - 1 + 1 = v.val + omega) + right_inv x := by + rcases x with u | j + · exact dif_pos rfl + · have h1 : peelVertexFun n ⟨j.val + 1, by + have := j.isLt + omega⟩ = Sum.inr ⟨j.val + 1 - 1, by + have := j.isLt + omega⟩ := + dif_neg (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 + show 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 + show peelVertexFun n ⟨0, h⟩ = Sum.inl () + exact dif_pos 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 + show j.val + 1 - 1 < n + have := j.isLt + omega⟩ := + dif_neg (show ¬ (j.succ.val = 0) from by + show ¬ (j.val + 1 = 0) + omega) + show peelVertexFun n j.succ = Sum.inr j + rw [h1] + exact congrArg Sum.inr (Fin.ext (by + show 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 + +/-- **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 := fun 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] + erw [peelFlagEquiv_inl_low d S ⟨i.val, hi⟩] + show (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] + show 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 + show i.val = d + (i.val - d) + omega)] + erw [peelFlagEquiv_inl_high d S] + show (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] + show 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⟩] + show 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 + show i.val = 0 + i.val + omega), + interleaveEquiv_inl_high] + show (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 + show i.val = d + (i.val - d) + omega)] + erw [peelFlagEquiv_inr_high d S] + show 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 + show i.val - d = 0 + (i.val - d) + omega), + interleaveEquiv_inr_high] + show (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. + pairing_comm := fun 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 + show 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 + show 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 + circles_eq := by + show 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 + · show ((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 + · show ((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 + show 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 => dif_pos i.isLt) + (fun j => by + have h1 : ¬ ((Fin.natAdd d j : + Fin (d + ds.sum)).val < d) := by + show ¬ (d + j.val < d) + omega + refine (dif_neg h1).trans ?_ + refine congrArg Fin.succ + (congrArg (blockAssign ds) (Fin.ext ?_)) + show d + j.val - d = j.val + omega)).trans ?_ + refine (Fragment.Equiv.relabelCongr + (tensorFragmentCongr (Fragment.Equiv.refl _) + (Fragment.Equiv.relabelCongr + (multiStarBlocks ds c) _)) _).trans ?_ + show ((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..52c5654410 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPerm.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 +-/ + +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. +-/ + +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 + letI := 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] + +-- Raised budget: `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 + +-- Raised budget: 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 + letI := 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 ?_ + show ((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..80e50a0bfd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarRepeat.lean @@ -0,0 +1,297 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 [if_pos 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 + show i < i + 1; omega), ?_, ?_, ?_⟩ + · rw [_root_.Equiv.swap_apply_left, + _root_.Equiv.swap_apply_right] + exact Fin.lt_def.mpr (by + show i < i + 1; omega) + · rw [_root_.Equiv.swap_apply_left] + exact hodd.2 + · rw [_root_.Equiv.swap_apply_right] + exact hodd.1 + · rw [if_neg 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 + show 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 [if_pos ⟨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 show 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 show j.val - 1 + 1 = j.val; omega) + refine ih (c ∘ σ) i ⟨j.val - 1, hb3⟩ hb1 ?_ ?_ hb2 + · show (c (σ i)).isRight + rw [show σ i = i from + _root_.Equiv.swap_apply_of_ne_of_ne + (Fin.ne_of_val_ne (by + show i.val ≠ j.val - 1; omega)) + (Fin.ne_of_val_ne (by + show i.val ≠ j.val - 1 + 1; omega))] + exact hodd + · show 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 + show i.val ≠ j.val - 1; omega)) + (Fin.ne_of_val_ne (by + show 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..7649dcaa8e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarSymm.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 +-/ + +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. +-/ + +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..ec9ba4e6a6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarTensorClass.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 +-/ + +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. +-/ + +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..f31c4b8798 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StdTransport.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec +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. +-/ + +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 + letI := P.braided + show (η P.ω ≫ ε P.ω : P.ω.obj (SkeinObj.mk 0) ⟶ + P.ω.obj (SkeinObj.mk 0)) = 𝟙 _ + exact Functor.Monoidal.η_ε P.ω + | m + 1 => by + letI := P.braided + show (δ 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 + letI := P.braided + show (ε P.ω ≫ η P.ω : SuperVect.tensorUnit ⟶ + SuperVect.tensorUnit) = 𝟙 _ + exact Functor.Monoidal.ε_η P.ω + | m + 1 => by + letI := P.braided + show ((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..a78f458792 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StrandTransport.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 +-/ + +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. +-/ + +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 + letI := P.braided + show (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 + show 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 + +-- Raised budget: 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 + letI := P.braided + rw [stdToOmega_one] + show (((λ_ (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 + show ((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 + letI := P.braided + rw [stdToOmega_one] + show (((λ_ (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 + show ((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..5f3a5d12d3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauCount.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData +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. +-/ + +namespace RS + +open Classical 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..5be7ed8f9f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauKey.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FlagEnum +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm +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. +-/ + +namespace RS + +open Classical 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..79aa73a238 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TopBraidMerge.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 +-/ + +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. +-/ + +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] + +-- Raised budget: 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 + show (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 + haveI := 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 + haveI := 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 + haveI := 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..7663a21be5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TwoBasis.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 +-/ + +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. +-/ + +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..5a40de62af --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexSign.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockOddList +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. +-/ + +namespace RS + +open Classical Finset + +variable {k ℓ : ℕ} + +-- Raised budget: 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..3e04c0ca30 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexValue.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 +-/ + +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. +-/ + +namespace RS + +open CategoryTheory Finset +open Classical + +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 ℓ) + +-- Raised budget: 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..ba758b08c4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomDichotomy.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiSemisimple +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. +-/ + +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..5aeccefd4e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomicIdempotents.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 +-/ + +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. +-/ + +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 [if_pos rfl] + unfold matUnit + rcases eq_or_ne k pi with rfl | hk + · simp + · simp [Pi.single_eq_of_ne hk] + · rw [if_neg (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 [if_neg (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 [if_neg (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 [if_neg (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 → ℕ} + [∀ i, NeZero (d i)] + (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, + if_pos rfl] + · intro p q hpq + rw [← map_mul, matUnit_mul_matUnit, if_neg hpq, map_zero] + · rw [← map_sum, matUnit_sum, map_one] + · intro p + refine ⟨?_, ?_, ?_⟩ + · show IsIdempotentElem _ + rw [IsIdempotentElem, ← map_mul, matUnit_mul_matUnit, + if_pos 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..4f2cf0e48c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockAssembly.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactor +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`. +-/ + +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..ca655b4ada --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockBounds.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 +-/ + +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. +-/ + +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..c084e34848 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean @@ -0,0 +1,459 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockSplice +import LeanPool.RegtsSevenster.RS.Novel.Envelope.Frobenius +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. +-/ + +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 [if_pos (Fin.ext hq : q = Fin.last c), if_pos hq] + · rw [if_neg (show q ≠ Fin.last c from fun h => + hq (congrArg Fin.val h)), if_neg 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 [if_pos hqc, hqc, if_neg (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 [if_neg hqc, + if_pos (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 -/ + +-- Raised budget: 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 + show 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 + show 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 + show 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) + show 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..3a8d633be8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactor.lean @@ -0,0 +1,966 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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 + show 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)) + +-- Raised budget: 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 + show (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 => + show 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 + show 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] + show (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 + show (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] + show (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 + show (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 -/ + +-- Raised budget: 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 + show 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 + show (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) + +-- Raised budget: 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 + show 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..4ffa7e3d9b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactorialTrace.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Algebra.FactorialTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactor +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`. +-/ + +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..57004f32ea --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockSplice.lean @@ -0,0 +1,940 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseCompose +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. +-/ + +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 [if_pos h] + · conv_lhs => + rw [show x = (⟨a + (x.val - a), by omega⟩ : Fin (a + b)) from + Fin.ext (by show x.val = a + (x.val - a); omega)] + rw [transposeEquiv_high a b (x.val - a) (by omega) (by omega) (by omega)] + simp only [if_neg 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 [if_pos hya] at hfwd; rw [if_neg (by omega)]; omega + · rw [if_neg hya] at hfwd; rw [if_pos (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`. -/ +private 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 [dif_pos h, Fin.val_mk] + rw [dif_neg (show ¬ K + K + n + w.val < K + K + n by omega)] + refine Fin.ext ?_; simp only []; omega + · simp only [dif_neg h, Fin.val_mk] + rw [dif_pos (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 [dif_pos h, Fin.val_mk] + rw [dif_neg (show ¬ w.val + n < n by omega)] + refine Fin.ext ?_; simp only []; omega + · simp only [dif_neg h, Fin.val_mk] + rw [dif_pos (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 dif_pos 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 [Fin.val_natAdd]; 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 dif_neg (by omega) + rw [hstep] + by_cases hk0 : ℓ.val - (K + n + n) < n + · -- z-high block (k < n case) + rw [if_pos 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 [if_neg 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, Fin.val_castAdd] + 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. -/ +private 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 [dif_pos hlo, Sum.elim_inl] + rw [dif_neg (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 [dif_neg hlo, dif_pos hhi, Sum.elim_inl] + rw [dif_pos (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 [dif_neg hlo, dif_neg (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 [dif_pos hj, dif_neg (show ¬ (⟨K + n + j.val, + by have := j.isLt; omega⟩ : Fin (K + n + n)).val < n by + simp only []; omega), + dif_pos (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 [dif_neg hj, dif_pos (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 [dif_neg (show ¬ (⟨k.val + n, by have := k.isLt; omega⟩ : + Fin (K + n + n)).val < n by simp only []; omega), + dif_neg (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 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 [dif_pos hlo, dif_pos hlo]; rfl + · by_cases hhi : w.val ≥ K + n + · rw [dif_neg hlo, dif_pos hhi, dif_neg hlo, dif_pos hhi]; rfl + · rw [dif_neg hlo, dif_neg (by omega), dif_neg hlo, dif_neg (by 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 [Fin.val_mk] + 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 [if_pos hlow] + · rw [show x = (⟨(K + n) + (x.val - (K + n)), by omega⟩ : + Fin ((K + n) + (K + n))) from Fin.ext + (by show 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. -/ +private noncomputable def relabel_defeq_collapse {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. -/ +private noncomputable def compose_relabel_castOut + {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) + (relabel_defeq_collapse G _)).trans + (relabel_defeq_collapse (F.compose G) _).symm + +/-! ### The bridge: the rotation as through-strands and cups -/ + +/-- **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. -/ +private noncomputable def block_bridge (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 := fun f => by + obtain ⟨w, b⟩ := f + show (((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. + · -- Through-strand low block (wire w < n) + 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 dif_pos 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.not_true, reduceIte, + Bool.false_eq_true, if_false, if_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, Fin.val_castAdd] + rw [blockOuterPerm_val] + simp only [Fin.val_mk] + 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_false, Bool.not_true, reduceIte, + Bool.false_eq_true, if_false, if_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 + · 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 [dif_neg hlo, dif_pos 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.not_false, Bool.not_true, reduceIte, + Bool.false_eq_true, if_false, if_true, 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 [Bool.not_false, Bool.not_true, reduceIte, + Bool.false_eq_true, if_false, if_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, Fin.val_castAdd] + rw [blockOuterPerm_val] + simp only [Fin.val_mk] + 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 [dif_neg hlo, dif_neg (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.not_false, Bool.not_true, reduceIte, + Bool.false_eq_true, if_false, if_true, 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, Fin.val_castAdd] + rw [blockOuterPerm_val] + simp only [Fin.val_mk] + 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 [Bool.not_false, Bool.not_true, reduceIte, + Bool.false_eq_true, if_false, if_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, Fin.val_castAdd] + rw [blockOuterPerm_val] + simp only [Fin.val_mk] + split_ifs <;> omega + pairing_comm := fun f => + 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. -/ +private noncomputable def block_reshuffle_decomp (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 + (block_bridge 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. -/ +private 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 + +/-- The last comparison of the block splice: the leg-extended +tensor against the rotated through-tensor. -/ +private noncomputable def block_splice_bridge (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 + rintro (g | ⟨k, c⟩) + -- ═══════ THE FRAGMENT'S OWN FLAGS ═══════ + · -- a G-flag crosses sides + show 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 [Fin.val_natAdd])] + 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_natAdd, 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 [Fin.val_natAdd]; 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_natAdd, 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 + -- ═══════ THE CUP FLAGS ═══════ + · -- a cup flag flips into a through-strand + show 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_inl, Sum.map_inr, + Bool.false_eq_true, if_false, if_true, reduceIte] + 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 [Fin.val_natAdd])] + 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 [Fin.val_natAdd])] + simp only [id_eq] + rw [block_ER_val, block_bigE_val] + simp only [Fin.val_castAdd, Fin.val_natAdd] + split_ifs <;> first + | omega + | (have hk := k.isLt; omega) + · simp only [Bool.not_true, Sum.map_inl, Sum.map_inr, + Bool.false_eq_true, if_false, if_true, reduceIte] + 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 [Fin.val_natAdd])] + 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 [Fin.val_natAdd])] + simp only [id_eq] + rw [block_ER_val, block_bigE_val] + simp only [Fin.val_castAdd, Fin.val_natAdd] + split_ifs <;> first + | omega + | (have hk := k.isLt; omega) + pairing_comm := by + rintro (g | ⟨k, c⟩) + · rfl + · rfl + circles_eq := by + show 𝔊.circles + (strandBundle K).circles = + (strandBundle K).circles + 𝔊.circles + omega + +/-! ### 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 _) + (block_reshuffle_decomp 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: compose_relabel_castOut (collapse the recast) + refine (Fragment.Equiv.relabelCongr + (Fragment.Equiv.relabelCongr + (compose_relabel_castOut + (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 + (relabel_defeq_collapse _ _)).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 block_splice_bridge 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..5784b0eb1b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockTower.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower +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. +-/ + +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 + show (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 + show (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 + show 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) σ)) + show 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..53c3f64de8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleNormal.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 +-/ + +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. +-/ + +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 + show 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..57ce49062e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleTrace.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowHom +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. +-/ + +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 + show catTrace (𝟙 (𝟙_ A)) = catTrace g ^ 0 + rw [catTrace_id, catDim_unit, pow_zero] + | n + 1 => by + show 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 + show (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] + show (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..a9aa4e74cf --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvAbelian.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 +-/ + +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. +-/ + +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 + show 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 + show 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 + haveI : HasFiniteBiproducts (Env f) := inferInstance + haveI : HasBinaryBiproducts (Env f) := + hasBinaryBiproducts_of_finite_biproducts _ + haveI := 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. -/ +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. -/ +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..934f55548f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDeligne.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LinearCategory +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. +-/ + +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 + show ((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 + show 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..b2758228a4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDelignePackage.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvSemisimple +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGrowth +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatRigid +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatEmbMonoidal +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiRigid +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiEmbBraided +import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidInstance +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackageRestrict +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. +-/ + +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 + letI := envAbelian f + exact (hD (Env f) (env_endOne f) + ⟨envStrand f 1, env_deligneGenerated f⟩ + (moderateLengthGrowth_of_endGrowth (Env 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..e67eece6b0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGenerator.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances +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. +-/ + +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 + haveI : 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] + show ∑ _j : PUnit, 𝟙 (x ⊗ y) ≫ 𝟙 (x ⊗ y) = 𝟙 (x ⊗ y) + simp + inv_hom_id := by + apply Mat_.hom_ext + intro i j + haveI : 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] + show ∑ _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 + show 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 + show 𝟙 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 + show 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 + show 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 + show 𝟙 (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 + show 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 -/ + +-- Raised budget: 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..14ef4b0e53 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGrowth.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGenerator +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. +-/ + +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 + haveI : ∀ 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 + show (((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..0c57056aae --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvInstances.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvAbelian +import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiMonoidal +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. +-/ + +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 + show (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 + show (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' + show (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' + show (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 + show (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 + show (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 + show X.p ⊗ₘ (0 : Y.X ⟶ Z.X) = 0 + rw [MonoidalPreadditive.tensor_zero] + zero_whiskerRight := by + intro X Y Z + apply Karoubi.hom_ext + show (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 + show 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 + show (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 + show 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 + show (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₂⟩ + show (𝟙 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₂⟩ + show (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 + show (𝟙 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₂⟩ + show (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 + show c • (φ i j + ψ i j) = c • φ i j + c • ψ i j + exact smul_add c _ _ + add_smul c d φ := by + funext i j + show (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 + show ∑ 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 + show ∑ 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 + show (𝟙 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 + show (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..464e6171d6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvSemisimple.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 +-/ + +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. +-/ + +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 + show 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 + show 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 + show 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 + show 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 + show 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 + show 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 + haveI : FiniteDimensional ℂ (End E) := envHomFinite f E E + haveI := 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 [dif_pos rfl, eqToHom_refl, cornerIncl_proj] + · rw [dif_neg 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..b50f91b7ff --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/FactorialTrace.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Algebra.FactorialTrace +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`. +-/ + +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..f8df78ea10 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/Frobenius.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleNormal +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceCyclic +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`. +-/ + +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 + show (if h : x.val < t then x else _).val = x.val + rw [dif_pos 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 + show (if h : x.val < t then x else _).val = _ + rw [dif_neg hx] + have hxeq : x = Fin.natAdd t ⟨x.val - t, by omega⟩ := + Fin.ext (by show 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 + show 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 ?_) + show (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] + show 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..c90f8ccdf2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinement.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 +-/ + +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. +-/ + +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..8563a88dde --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinementSharp.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowthSharp +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`. +-/ + +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..1d91d59a9d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiEmbBraided.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 +-/ + +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. +-/ + +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 + show (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] + show 𝟙 (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..3703c77b82 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiMonoidal.lean @@ -0,0 +1,839 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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` -/ + +-- Raised budget: every field carries its own idempotent +-- compatibility proof, and they elaborate together. +/-- 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, tensorHom_idem X.idem Y.idem⟩ + whiskerLeft X _ _ f := + ⟨X.p ⊗ₘ f.f, karoubi_tensorHom_comm (⟨X.p, by simp [X.idem]⟩ : X ⟶ X) f⟩ + whiskerRight f Y := + ⟨f.f ⊗ₘ Y.p, karoubi_tensorHom_comm f (⟨Y.p, by simp [Y.idem]⟩ : Y ⟶ Y)⟩ + tensorHom f g := ⟨f.f ⊗ₘ g.f, 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, + 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, + 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, + conj_comm _ _ + (tensorHom_idem (by simp) X.idem) X.idem + _ (leftUnit_nat X)⟩ + inv := ⟨X.p ≫ (λ_ X.X).inv, + 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, + conj_comm _ _ + (tensorHom_idem X.idem (by simp)) X.idem + _ (rightUnit_nat X)⟩ + inv := ⟨X.p ≫ (ρ_ X.X).inv, + 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] + +-- Raised budget: `ofTensorHom` takes eleven axioms at once. +/-- Those data satisfy the monoidal axioms, each inherited from the +ambient category by conjugation. -/ +instance karoubiMonoidal + [Category.{v} C] [MonoidalCategory C] : MonoidalCategory (Karoubi C) := + MonoidalCategory.ofTensorHom + (id_tensorHom_id := karoubi_id_tensorHom_id) + (id_tensorHom := karoubi_id_tensorHom) + (tensorHom_id := karoubi_tensorHom_id) + (tensorHom_comp_tensorHom := karoubi_tensorHom_comp) + (associator_naturality := karoubi_associator_naturality) + (leftUnitor_naturality := karoubi_leftUnitor_naturality) + (rightUnitor_naturality := karoubi_rightUnitor_naturality) + (pentagon := karoubi_pentagon) + (triangle := 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)`. -/ + +-- Raised budget: 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. -/ +private 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, + 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, + 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 + +-- Raised budget: 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..70d92031a8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiRigid.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 +-/ + +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. +-/ + +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. -/ +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 + show 𝟙 (𝟙_ 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 + show ((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..47390c4153 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiSemisimple.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleAll +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. +-/ + +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 + haveI : 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 + show 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..6857378bb7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean @@ -0,0 +1,468 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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.ι`. +-/ + +noncomputable section + +namespace RS + +open scoped Classical + +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 + +@[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 + +@[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 + +private 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 + +private 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 + +@[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 + +@[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 -/ + +-- Raised budget: 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] + +private 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 := matBraid_hom_inv M N + inv_hom_id := matBraid_inv_hom M N + +/-! ### Braiding naturality -/ + +-- Raised budget: 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] + +-- Raised budget: 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 := mat_braiding_naturality_right + braiding_naturality_left := mat_braiding_naturality_left + hexagon_forward := mat_hexagon_forward + hexagon_reverse := mat_hexagon_reverse + +end Braided + +/-! ### `SymmetricCategory` instance -/ + +section Symmetric + +-- Raised budget: 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 + show 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..c2e596e12c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean @@ -0,0 +1,504 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatBraided +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. +-/ + +noncomputable section + +namespace RS + +open scoped Classical + +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] + haveI : Subsingleton ((Mat_.embedding C).obj Y ⊗ (Mat_.embedding C).obj X').ι + := + inferInstanceAs (Subsingleton (PUnit × PUnit)) + haveI : 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] + show (f ⊗ₘ (𝟙 ((Mat_.embedding C).obj X') : Mat_.Hom _ _) i.2 a.2) ≫ 𝟙 (Y ⊗ + X') = + 𝟙 (X ⊗ X') ≫ (f ▷ X') + haveI : Subsingleton ((Mat_.embedding C).obj X').ι := inferInstanceAs + (Subsingleton PUnit) + rw [show i.2 = a.2 from Subsingleton.elim _ _, Mat_.id_apply_self] + show (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] + haveI : Subsingleton ((Mat_.embedding C).obj X' ⊗ (Mat_.embedding C).obj Y).ι + := + inferInstanceAs (Subsingleton (PUnit × PUnit)) + haveI : 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] + show ((𝟙 ((Mat_.embedding C).obj X') : Mat_.Hom _ _) i.1 a.1 ⊗ₘ f) ≫ 𝟙 (X' ⊗ + Y) = + 𝟙 (X' ⊗ X) ≫ (X' ◁ f) + haveI : Subsingleton ((Mat_.embedding C).obj X').ι := inferInstanceAs + (Subsingleton PUnit) + rw [show i.1 = a.1 from Subsingleton.elim _ _, Mat_.id_apply_self] + show (𝟙 X' ⊗ₘ f) ≫ 𝟙 (X' ⊗ Y) = 𝟙 (X' ⊗ X) ≫ (X' ◁ f) + rw [id_tensorHom, comp_id, id_comp] + +/-! #### Associativity -/ + +-- Restate the private Mat_ associator lemma +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 + +-- Raised budget: 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 + haveI : Subsingleton ((Mat_.embedding C).obj X).ι := inferInstanceAs + (Subsingleton PUnit) + haveI : Subsingleton ((Mat_.embedding C).obj Y).ι := inferInstanceAs + (Subsingleton PUnit) + haveI : 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] + haveI : 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] + haveI : 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] + show (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] + show (𝟙 (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] + haveI : 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] + haveI : 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', + dif_pos (Subsingleton.elim i.1.1 a2.1), + dif_pos (Subsingleton.elim i.1.2 a2.2.1), + dif_pos (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 + show (α_ 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] + show (α_ 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 +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 + +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 + +-- Raised budget: 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 + haveI : Subsingleton ((Mat_.embedding C).obj (𝟙_ C)).ι := + inferInstanceAs (Subsingleton PUnit) + haveI : Subsingleton ((Mat_.embedding C).obj X).ι := + inferInstanceAs (Subsingleton PUnit) + haveI : 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', + dif_pos (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] + haveI : 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] + haveI : 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] + show ((𝟙 ((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] + show (𝟙 (𝟙_ 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 + haveI : Subsingleton ((Mat_.embedding C).obj X).ι := inferInstanceAs + (Subsingleton PUnit) + haveI : Subsingleton ((Mat_.embedding C).obj (𝟙_ C)).ι := + inferInstanceAs (Subsingleton PUnit) + haveI : 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', + dif_pos (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] + haveI : 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] + haveI : 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] + show ((𝟙 ((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] + show (𝟙 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`. -/ +private 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 := matEmb_μ_natural_left + μIso_hom_natural_right := matEmb_μ_natural_right + associativity := matEmb_associativity + left_unitality := matEmb_left_unitality + right_unitality := 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) +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 + +-- Raised budget: 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 + show 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 + haveI : Subsingleton ((Mat_.embedding C).obj X).ι := inferInstanceAs + (Subsingleton PUnit) + haveI : 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] + haveI : 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] + show 𝟙 (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] + haveI : 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', + dif_pos (Subsingleton.elim i.2 b.1), + dif_pos (Subsingleton.elim i.1 b.2)] + erw [eqToHom_refl, id_comp]; rfl + rw [h_braid] + show (β_ 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 := 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..f9b3cf9c57 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.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 +-/ + +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`. +-/ + +noncomputable section + +namespace RS + +open scoped Classical + +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] private 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. -/ +private 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] private 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. -/ + +/-- The associator hom in `Mat_ C`. -/ +private 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 + +/-- The associator inv in `Mat_ C`. -/ +private 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 + +/-- The left unitor hom in `Mat_ C`. -/ +private 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 + +/-- The left unitor inv in `Mat_ C`. -/ +private 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 + +/-- The right unitor hom in `Mat_ C`. -/ +private 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 + +/-- The right unitor inv in `Mat_ C`. -/ +private 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. -/ + +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] + +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] + +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] + +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] + +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] + +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`. -/ +private 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 := matAssoc_hom_inv M N K + inv_hom_id := matAssoc_inv_hom M N K + +/-- The left unitor isomorphism in `Mat_ C`. -/ +private 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 := matLeftUnitor_hom_inv M + inv_hom_id := matLeftUnitor_inv_hom M + +/-- The right unitor isomorphism in `Mat_ C`. -/ +private 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 := matRightUnitor_hom_inv M + inv_hom_id := 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] + +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] + +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] + +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`. -/ + +-- Raised budget: the pentagon is checked entrywise on a quadruple +-- index, so four matrix compositions expand. +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] + +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) := + MonoidalCategory.ofTensorHom + (id_tensorHom_id := mat_id_tensorHom_id) + (id_tensorHom := fun _ {_ _} _ => rfl) + (tensorHom_id := fun _ _ => rfl) + (tensorHom_comp_tensorHom := mat_tensorHom_comp) + (associator_naturality := mat_associator_naturality) + (leftUnitor_naturality := mat_leftUnitor_naturality) + (rightUnitor_naturality := mat_rightUnitor_naturality) + (pentagon := mat_pentagon) + (triangle := 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..5b9ed3aea6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.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 +-/ + +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. +-/ + +noncomputable section + +namespace RS + +open scoped Classical + +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 + +@[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 + +@[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 + +@[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 + +@[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 + +@[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 + +@[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 -/ + +/-- 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 + +/-- 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 := + dif_neg 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 := + dif_neg h + +/-! ### The snake identities -/ + +-- Raised budget: 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', dif_neg (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', dif_neg (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', dif_neg (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', dif_neg (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. -/ +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' := mat_snake_one M + evaluation_coevaluation' := 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..9459c39603 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatSemisimple.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 +-/ + +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. +-/ + +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 + show c • (φ i j + ψ i j) = c • φ i j + c • ψ i j + exact smul_add c _ _ + add_smul c d φ := by + funext i j + show (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 + show ∑ 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 + show ∑ 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 + show (∑ 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 + show (∑ 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 + dif_neg (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 + dif_neg (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 dif_pos ⟨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 + show φ 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 + haveI : 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..da102bc43f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentMatTrace.lean @@ -0,0 +1,762 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show ((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 + haveI := karoubiEndFinite f (M.X i) + haveI := 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] + rfl + +/-- 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 + 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 = _ + 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 := + dif_neg h + +/-- The scalar matrix of the zero endomorphism is zero. -/ +theorem AtomResolution.B_zero : A.B (0 : End M) = 0 := by + funext p q + show 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 dif_pos 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]; rfl) + | 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 dif_pos 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 dif_pos 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)))) := dif_pos 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..9bed1ad22e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentTrace.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement +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. +-/ + +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..dfdca2b0d6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ObjectTower.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarPermTrace +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast +import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarTrace +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. +-/ + +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..3b7783682f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/PermTrace.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowSplit +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. +-/ + +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 + show catTrace (permMor X 0 1 ≫ powHom X g 0) = 1 + rw [permMor_one, powHom_zero, 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]) + show 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] + rfl + +/-! ## 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..b56fe07ad8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/RankDimension.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 +-/ + +import LeanPool.RegtsSevenster.RS.DimensionDefinitions +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. +-/ + +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..141ab837e0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarPermTrace.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.PermTrace +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. +-/ + +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 + show 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..abd589b3c5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarTrace.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Trace +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. +-/ + +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 + show 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..01057e583b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleAll.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactorialTrace +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. +-/ + +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..bb1bfd3ee8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleEnd.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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..7bdb8a4db5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinDimBound.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinementSharp +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower +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`. +-/ + +namespace RS + +open Finset + +/-- The chosen block dimension is positive. -/ +theorem jtSimple_dim_pos (μ : YoungDiagram) : + 0 < nDim (jtSimple μ) := by + haveI := jtSimple_simple μ + haveI := IsSimpleModule.nontrivial + (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) (jtSimple μ) + haveI : 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..5aa05ce550 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTower.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinLinear +import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor +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`. +-/ + +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 + show 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 + show 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 + show 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..5e6790565d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTrace.lean @@ -0,0 +1,83 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower +import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseUnion +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. +-/ + +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 + show 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 + show 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..97da532975 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SuperKill.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinDimBound +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. +-/ + +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 + letI := P.additive + letI := 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..039b9e3c25 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPerm.lean @@ -0,0 +1,672 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.CatTheory.TensorPow +import LeanPool.RegtsSevenster.RS.Common.PermTopSplit +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. +-/ + +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 + unfold swapTop + slice_lhs 3 4 => rw [Iso.inv_hom_id] + rw [Category.id_comp] + slice_lhs 2 3 => rw [← MonoidalCategory.whiskerLeft_comp, + SymmetricCategory.symmetry, MonoidalCategory.whiskerLeft_id] + rw [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 + show 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] + +/-- **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 + rw [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 + rw [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 σ τ + show 𝟙 _ = 𝟙 _ ≫ 𝟙 _ + 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..4baec5c5f2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPermCast.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 +-/ + +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`. +-/ + +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 + show (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 fun σ => ?_ + show 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 + show 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..f6467a647f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowHom.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 +-/ + +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`). +-/ + +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..f3ca1e4cec --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowSplit.lean @@ -0,0 +1,444 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowHom +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. +-/ + +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 + show ((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 + show 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)) + show ((α_ (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] + show 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] + show (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] + calc (swapTop X (p + r) ≫ (insertTop X (p + r) k ▷ X)) ≫ + (splitPow X p (r + 1 + 1)).hom + = swapTop X (p + r) ≫ ((insertTop X (p + r) k ▷ X) ≫ + (splitPow X p (r + 1 + 1)).hom) := Category.assoc _ _ _ + _ = swapTop X (p + r) ≫ ((splitPow X p (r + 1 + 1)).hom ≫ + (tensorPow A X p ◁ (insertTop X r k ▷ X))) := + congrArg (fun z => swapTop X (p + r) ≫ z) hstep + _ = (swapTop X (p + r) ≫ (splitPow X p (r + 1 + 1)).hom) ≫ + (tensorPow A X p ◁ (insertTop X r k ▷ X)) := + (Category.assoc _ _ _).symm + _ = ((splitPow X p (r + 1 + 1)).hom ≫ + (tensorPow A X p ◁ swapTop X r)) ≫ + (tensorPow A X p ◁ (insertTop X r k ▷ X)) := + congrArg + (fun z => z ≫ (tensorPow A X p ◁ (insertTop X r k ▷ X))) + (swapTop_comp_splitPow X p r) + _ = (splitPow X p (r + 1 + 1)).hom ≫ + (tensorPow A X p ◁ swapTop X r) ≫ + (tensorPow A X p ◁ (insertTop X r k ▷ X)) := + Category.assoc _ _ _ + +/-! ## 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] + show (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] + show 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] + show 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 + show 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] + calc ((permMor X (p + q) (blockSum σ (restPerm τ)) ▷ X) ≫ + insertTop X (p + q) (q - (topImage τ : ℕ))) ≫ + (splitPow X p (q + 1)).hom + = (permMor X (p + q) (blockSum σ (restPerm τ)) ▷ X) ≫ + (insertTop X (p + q) (q - (topImage τ : ℕ)) ≫ + (splitPow X p (q + 1)).hom) := Category.assoc _ _ _ + _ = (permMor X (p + q) (blockSum σ (restPerm τ)) ▷ X) ≫ + ((splitPow X p (q + 1)).hom ≫ + (tensorPow A X p ◁ + insertTop X q (q - (topImage τ : ℕ)))) := + congrArg (fun z => + (permMor X (p + q) (blockSum σ (restPerm τ)) ▷ X) ≫ z) + hi + _ = ((permMor X (p + q) (blockSum σ (restPerm τ)) ▷ X) ≫ + (splitPow X p (q + 1)).hom) ≫ + (tensorPow A X p ◁ + insertTop X q (q - (topImage τ : ℕ))) := + (Category.assoc _ _ _).symm + _ = ((splitPow X p (q + 1)).hom ≫ + (permMor X p σ ⊗ₘ + (permMor X q (restPerm τ) ⊗ₘ 𝟙 X))) ≫ + (tensorPow A X p ◁ + insertTop X q (q - (topImage τ : ℕ))) := by + rw [← tensorHom_id + (permMor X (p + q) (blockSum σ (restPerm τ))) X, hw] + rfl + _ = (splitPow X p (q + 1)).hom ≫ + ((permMor X p σ ⊗ₘ + (permMor X q (restPerm τ) ⊗ₘ 𝟙 X)) ≫ + (𝟙 (tensorPow A X p) ⊗ₘ + insertTop X q (q - (topImage τ : ℕ)))) := by + rw [Category.assoc, id_tensorHom] + _ = (splitPow X p (q + 1)).hom ≫ + (permMor X p σ ⊗ₘ + ((permMor X q (restPerm τ) ⊗ₘ 𝟙 X) ≫ + insertTop X q (q - (topImage τ : ℕ)))) := by + rw [tensorHom_comp_tensorHom, Category.comp_id] + _ = (splitPow X p (q + 1)).hom ≫ + (permMor X p σ ⊗ₘ + ((permMor X q (restPerm τ) ▷ X) ≫ + insertTop X q (q - (topImage τ : ℕ)))) := by + rw [tensorHom_id] + +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..de422fc01f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZeta.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentTrace +import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaRational +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. +-/ + +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..1a6c595b9f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZetaSharp.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZeta +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. +-/ + +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..cf029e2e41 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CircleValue.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 +-/ + +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. +-/ + +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 + show (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..0c3fcd3ae2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CoordIso.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 +-/ + +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. +-/ + +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..c6423b13e9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/Coordinates.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 +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Super.OrthonormalBasis +import LeanPool.RegtsSevenster.RS.Classical.Super.SymplecticBasis +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. +-/ + +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 [dif_pos h] + constructor + · intro hh + have h2 : (j : ℕ) = i.val + ℓ := congrArg Fin.val hh + omega + · intro hh + refine Fin.ext ?_ + show (j : ℕ) = i.val + ℓ + omega + · rw [dif_neg (Nat.not_lt.mpr h)] + constructor + · intro hh + have h2 : (j : ℕ) = i.val - ℓ := congrArg Fin.val hh + omega + · intro hh + refine Fin.ext ?_ + show (j : ℕ) = i.val - ℓ + omega + by_cases hp : j = oddPartner ℓ i + · rw [if_pos hp] + unfold oddPartnerSign + rcases hpart.mp hp with h1 | h1 + · rw [if_pos h1, if_pos (show i.val < ℓ by omega)] + norm_num + · rw [if_neg (show ¬ (i : ℕ) + ℓ = (j : ℕ) by omega), if_pos h1, + if_neg (show ¬ i.val < ℓ by omega)] + norm_num + · rw [if_neg hp, + if_neg (fun hh => hp (hpart.mpr (Or.inl hh))), + if_neg (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, if_pos rfl, mul_one] + · exact mul_comm _ _ + · intro m _ hm + rw [if_neg 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), + if_pos (oddPartner_invol ℓ i).symm, oddPartner_invol] + · ring + · intro m _ hm + rw [if_neg (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..c0e835243b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CopairUnique.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate +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. +-/ + +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 + show 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 + show 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 -/ + +-- Raised budget: instantiating the abstract contraction families at +-- the standard model crosses the reduced and unreduced type +-- presentations, so the definitional unification is heavy. +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 + refine contractionMap_injective (stdFormEvenBilin k) + (stdFormEvenBilin_nondegenerate k) (LinearMap.ext fun x => ?_) + exact ((DFunLike.congr_fun + ((congrArg (contractionMap (stdFormEvenBilin k)) hS).trans + (map_sum (contractionMap (stdFormEvenBilin k)) + (fun i => i.1 ⊗ₜ[ℂ] i.2) S)) x).trans + ((LinearMap.sum_apply S _ x).trans + ((Finset.sum_congr rfl fun i _ => + (contractionMap_tmul _ i.1 i.2 x).trans + (congrArg (· • i.2) + (formEvenBlock_stdForm k ℓ x i.1).symm)).trans + (hi x)))).trans + (contractionMap_stdCopairEvenElem k x).symm + have ho : ((formCoevMap C') 1).2 = stdCopairOddElem ℓ := by + refine contractionMap_injective (stdFormOddBilin ℓ) + (stdFormOddBilin_nondegenerate ℓ) (LinearMap.ext fun x => ?_) + exact ((DFunLike.congr_fun + ((congrArg (contractionMap (stdFormOddBilin ℓ)) hT).trans + (map_sum (contractionMap (stdFormOddBilin ℓ)) + (fun i => i.1 ⊗ₜ[ℂ] i.2) T)) x).trans + ((LinearMap.sum_apply T _ x).trans + ((Finset.sum_congr rfl fun i _ => + (contractionMap_tmul _ i.1 i.2 x).trans + (congrArg (· • i.2) + (formOddBlock_stdForm k ℓ x i.1).symm)).trans + (hiii x)))).trans + (contractionMap_stdCopairOddElem ℓ x).symm + 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..7225838d1b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/Nondegenerate.lean @@ -0,0 +1,309 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`). +-/ + +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..fd9049c43c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/SnakeTransport.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Extraction.CoordIso +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`. +-/ + +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⟩ + letI EPV : ExactPairing V V := exactPairingOfSnake b C h1 h2 + letI 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 + show 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 + show ((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..888ab06359 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdDuality.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 +-/ + +import LeanPool.RegtsSevenster.RS.Common.ProdSum +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. +-/ + +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 + show (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 + show (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 + show 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 + show 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 + show -(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 + show -(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 + show -(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 + show -(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..3bd3f07830 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.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 +-/ + +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. +-/ + +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 + set_option synthInstance.maxHeartbeats 1000000 in + all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, + stdCopairOddElem, + mk_sum_split, mk_sum_left, mk_add_left, + mk_smul_left, mk_smul_right, + equiv_zero, lmap_zero, + TensorProduct.tmul_add, TensorProduct.tmul_sum, + TensorProduct.sum_tmul, + TensorProduct.tmul_smul, + Prod.fst_sum, Prod.snd_sum, Prod.fst_add, Prod.snd_add, + stdFormEvenBilin, stdFormOddBilin, + stdFormEven, stdE, stdF, stdG] + 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, if_pos] + · 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 + set_option synthInstance.maxHeartbeats 1000000 in + all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, + stdCopairOddElem, + mk_sum_split, mk_sum_left, mk_sum_right, + mk_add_right, mk_smul_left, mk_smul_right, + equiv_zero, lmap_zero, + TensorProduct.tmul_add, TensorProduct.tmul_sum, + TensorProduct.tmul_smul, + Prod.fst_sum, Prod.snd_sum, Prod.fst_add, Prod.snd_add, + stdFormEvenBilin, stdFormOddBilin, + stdFormOdd, stdE, stdF, stdG] + 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 [if_pos 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 [if_neg (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 + set_option synthInstance.maxHeartbeats 1000000 in + all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, + stdCopairOddElem, + mk_sum_split, mk_sum_left, mk_add_left, + mk_smul_left, mk_smul_right, + equiv_zero, lmap_zero, + TensorProduct.tmul_sum, + TensorProduct.add_tmul, TensorProduct.sum_tmul, + TensorProduct.tmul_smul, TensorProduct.smul_tmul, + Prod.fst_sum, Prod.snd_sum, Prod.fst_add, Prod.snd_add, + stdFormEvenBilin, stdFormOddBilin, + stdFormEven, stdE, stdF, stdG] + 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, if_pos] + · 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 + set_option synthInstance.maxHeartbeats 1000000 in + all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, + stdCopairOddElem, + mk_sum_split, mk_sum_left, mk_sum_right, mk_add_left, + mk_smul_left, mk_smul_right, + equiv_zero, lmap_zero, + TensorProduct.add_tmul, TensorProduct.sum_tmul, + TensorProduct.tmul_smul, TensorProduct.smul_tmul, + Prod.fst_sum, Prod.snd_sum, Prod.fst_add, Prod.snd_add, + stdFormEvenBilin, stdFormOddBilin, + stdFormOdd, stdE, stdF, stdG] + 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 [if_pos 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 [if_neg (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' := std_coev_ev k ℓ + evaluation_coevaluation' := 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..c102dffe25 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdSuper.lean @@ -0,0 +1,197 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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, if_neg 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, if_pos rfl, mul_one] + · rw [Pi.single_eq_of_ne (fun hh => h hh.symm), if_neg 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 => ?_) + show -(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 [if_pos rfl, if_pos rfl, mul_neg, ← Int.cast_mul, + oddPartnerSign_mul_self, Int.cast_one] + · rw [if_neg (fun hh : oddPartner ℓ j = oddPartner ℓ i => + h (by + have := congrArg (oddPartner ℓ) hh + rwa [oddPartner_invol, oddPartner_invol, eq_comm] at this)), + mul_zero, if_neg 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 (if_pos 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 (if_pos 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..ec8a1f0b74 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalAgreement.lean @@ -0,0 +1,354 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalIndependence +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. +-/ + +namespace RS + +open scoped Classical + +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) + +/-- 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 -/ + +/-- **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 [if_pos hm, + if_pos ((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 [if_pos (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 [if_neg hm, if_neg (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' + letI : 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..68e6b87711 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalIndependence.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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..0de374d4ad --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedInstance.lean @@ -0,0 +1,383 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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 + show b + x.val = b + x.val + rfl), + tensorMapEquiv_natAdd, + transposeEquiv_low a c x.val h1 (by omega) (by omega)] + exact (by + show (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 + show 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 + show 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 + show 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 + show 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 + show (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 + show 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 + show 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 + show a + (c + (x.val - a)) = (a + c) + (x.val - a) + omega), + tensorMapEquiv_natAdd] + exact (by + show 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 + show 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 + show 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 + show 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 + show 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 + show 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 + show 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..2b35d01164 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedNat.lean @@ -0,0 +1,359 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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] + show (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 + show 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 + show x.val = k + (x.val - k) + omega), + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_castAdd, + _root_.Equiv.trans_apply] + show (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 + show 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 + show x.val = (k + s) + (x.val - (k + s)) + omega), + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_natAdd, + _root_.Equiv.trans_apply] + show (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 + show 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 + show x.val = (k + s) + (k + (x.val - ((k + s) + k))) + omega), + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_natAdd, + _root_.Equiv.trans_apply] + show (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] + show (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 + show 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 + show x.val = s + (x.val - s) + omega), + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_castAdd, + _root_.Equiv.trans_apply] + show (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 + show 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 + show x.val = (s + k) + (x.val - (s + k)) + omega), + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_natAdd, + _root_.Equiv.trans_apply] + show (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 + show 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 + show x.val = (s + k) + (t + (x.val - ((s + k) + t))) + omega), + _root_.Equiv.trans_apply, + finSumFinEquiv_symm_apply_natAdd, + _root_.Equiv.trans_apply] + show (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..26fd7cb943 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleClose.lean @@ -0,0 +1,585 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarPrep +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. +-/ + +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 ?_) + show a.val = m + (a.val - m) + omega + · refine ⟨⟨b.val - m, by have := b.isLt; omega⟩, Or.inr ?_⟩ + refine congrArg Sum.inr (Fin.ext ?_) + show 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⟩, _⟩ := + dif_pos h + rw [h1] + show (⟨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⟩, _⟩ := + dif_neg h + rw [h1] + show (⟨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⟩)) + show bcPhiFun m ⟨a.val, by omega⟩ = _ + have h1 : bcPhiFun m ⟨a.val, by omega⟩ = + ⟨Sum.inl ⟨a.val, by omega⟩, _⟩ := dif_pos 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⟩)) + show bcPhiFun m ⟨m + b.val, by omega⟩ = _ + have h1 : bcPhiFun m ⟨m + b.val, by omega⟩ = + ⟨Sum.inr ⟨m + b.val - m, by omega⟩, _⟩ := + dif_neg (show ¬ m + b.val < m by omega) + rw [h1] + exact Subtype.ext (congrArg Sum.inr (Fin.ext (by + show 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 + show (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 (dif_pos hx) + show 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 show 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 + show (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 (dif_neg hx) + show bcDelta m ((((interfaceSurvEquiv m m m).trans + finSumFinEquiv).symm x)).val = (bcPhiFun m x).val + rw [hval, hbc] + refine congrArg Sum.inr (Fin.ext ?_) + show ((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 show 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 + show 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 + +-- Raised budget: 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 + show ((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..9de6ae950f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleMapClasses.lean @@ -0,0 +1,338 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance +import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleTensor +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. +-/ + +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 + show 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 + show (((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 ?_ + show ((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 show 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 + show 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 + show 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 + show 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 + show 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..ed8f84e30e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleTensor.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 +-/ + +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)). +-/ + +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 [dif_pos h] + · simp only [dif_neg h] + exact Prod.ext (Fin.ext (by + show a + (f.1.val - a) = f.1.val + omega)) rfl + right_inv g := by + rcases g with ⟨k, c⟩ | ⟨l, c⟩ + · simp only [dif_pos k.isLt] + · simp only [dif_neg (show ¬ a + l.val < a by omega)] + refine congrArg Sum.inr (Prod.ext (Fin.ext ?_) rfl) + show 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) := dif_pos h + show (tensorFragment (strandBundle a) + (strandBundle b)).attach (bundleFlagEquiv a b (k, c)) = _ + rw [hbfe] + rcases c with _ | _ + · show 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) + · show 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) := + dif_neg h + show (tensorFragment (strandBundle a) + (strandBundle b)).attach (bundleFlagEquiv a b (k, c)) = _ + rw [hbfe] + rcases c with _ | _ + · show 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 + show a + (k.val - a) = k.val + omega)) + · show 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 + show (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) := dif_pos h + have h2 : bundleFlagEquiv a b (k, c) = + Sum.inl (⟨k.val, h⟩, c) := dif_pos h + show bundleFlagEquiv a b (k, !c) = _ + rw [h1] + show _ = (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) := + dif_neg h + have h2 : bundleFlagEquiv a b (k, c) = + Sum.inr (⟨k.val - a, by have := k.isLt; omega⟩, c) := + dif_neg h + show bundleFlagEquiv a b (k, !c) = _ + rw [h1] + show _ = (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..4f6a896116 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonExistence.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 +-/ + +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`). +-/ + +namespace RS + +open scoped Classical + +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} [LinearOrder α] + {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 := + 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 [if_pos 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 [if_neg 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..80bc026f82 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonTransport.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 +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +/-! ## 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..76343ec573 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonicalFrame.lean @@ -0,0 +1,573 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathNonSep +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`). +-/ + +namespace RS + +open scoped Classical + +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)) + show 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 + show 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..80ee879be1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChainAgreement.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 +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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..8279d7a776 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordCount.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 +-/ + +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. +-/ + +namespace RS + +open Classical + +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 [dif_pos 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 [dif_neg h, dif_neg 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..b9f4b6a3a9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordLabels.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature +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. +-/ + +namespace RS + +open scoped Classical + +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..388eef4419 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordParity.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon +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. +-/ + +namespace RS + +open scoped Classical + +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..5e7810f985 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordSwapParity.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordParity +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). +-/ + +namespace RS + +open scoped Classical + +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..eb255c735a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotate.lean @@ -0,0 +1,1554 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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)). +-/ + +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] + show 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] + show 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 ?_)) + · show 0 + i.val = i.val + omega + · rfl + · refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) + · show 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) + show 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 + show 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))))))) + +/-- **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) := + Fragment.mapPairs_wf iL.symm _ wfqs1 + 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.glueList X (lhsQs2 m n p) wfqs2).Equiv + ((Fragment.glueList A + (Fragment.inlPairs (interfacePairs m n p) ++ + (pBlock m n p ++ mBlock m n p)) + (lhsCA_wf m n p)).relabel + ((Fragment.appendFlatten _ _ + ((lhsCA_wf m n p).append_sep)).symm.trans + (Fragment.foldSurvivingPermEquiv + ((lhs_pairs_lift m n p) ▸ + List.Perm.refl _)).symm)) := + (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 : (N.disjUnion K).Equiv (X.relabel iL) := + (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 : (((F.compose H).relabel + (finCongr (by omega : m + p = 0 + (m + p)))).disjUnion + (K.relabel + (finCongr (by omega : m + p = m + p + 0)))).Equiv + ((N.disjUnion K).relabel σL) := + (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))))))))))) + +/-- **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) := + Fragment.mapPairs_wf MR.symm _ wfq3 + 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.glueList UPB (rotQ4 m n p) wfq4).Equiv + ((Fragment.glueList A + (pBlock m n p ++ (nBlock m n p ++ mBlock m n p)) + (rotatePairsR_wf m n p)).relabel + ((Fragment.appendFlatten _ _ + ((rotatePairsR_wf m n p).append_sep)).symm.trans + (Fragment.foldSurvivingPermEquiv + ((rot_q4_eq m n p) ▸ List.Perm.refl _)).symm)) := + (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 : A.Equiv + ((F.disjUnion (K.disjUnion H)).relabel (rotBridge m n p)) := + (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 : XR.Equiv (UPB.relabel MR) := + (Fragment.glueListCongr + (Fragment.Equiv.relabelFlip BE) _ _).trans + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv + ((A.relabel (rotBridge m n p).symm)) + (mapPairs_symm_cancel (rotBridge m n p).symm + (Fragment.inrPairs (α := Fin (m + n)) + (hkPairs m n p))).symm + (Fragment.inrPairs_wf _ (hkPairs_wf m n p)) + (Fragment.mapPairs_wf (rotBridge m n p).symm _ wfground) + ((mapPairs_symm_cancel (rotBridge m n p).symm + (Fragment.inrPairs (α := Fin (m + n)) + (hkPairs m n p))).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListRelabel A (rotBridge m n p).symm + ground wfground).trans + ((Fragment.Equiv.relabelCongr + (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 _))) + (Fragment.foldSurvivingMapEquiv + (rotBridge m n p).symm ground)).trans + (Fragment.Equiv.relabelTrans _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel (rotBridge m n p).symm + (Fragment.inrPairs (α := Fin (m + n)) + (hkPairs m n p))).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _))) + -- ═══════ STAGE 2: THE EMBEDDED FOLD ═══════ + -- CR5: transport across the bridge. + have CR5 := (Fragment.glueListCongr CRX (rotQ3 m n p) + wfq3).trans + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (UPB.relabel MR) + (mapPairs_symm_cancel MR (rotQ3 m n p)).symm + wfq3 (Fragment.mapPairs_wf MR _ wfq4) + ((mapPairs_symm_cancel MR (rotQ3 m n p)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListRelabel UPB MR (rotQ4 m n p) + wfq4).trans + ((Fragment.Equiv.relabelCongr CRapp + (Fragment.foldSurvivingMapEquiv MR + (rotQ4 m n p))).trans + (Fragment.Equiv.relabelTrans _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel MR (rotQ3 m n p)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _))) + -- E5: the embedded fold. + have E5 : (F.disjUnion XKH).Equiv (XR.relabel i') := + (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 + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv (XR.relabel i') + (mapPairs_symm_cancel i' (rotQ2 m n p)).symm + wfq2 (Fragment.mapPairs_wf i' _ wfq3) + ((mapPairs_symm_cancel i' (rotQ2 m n p)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListRelabel XR i' (rotQ3 m n p) + wfq3).trans + ((Fragment.Equiv.relabelCongr CR5 + (Fragment.foldSurvivingMapEquiv i' + (rotQ3 m n p))).trans + (Fragment.Equiv.relabelTrans _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel i' (rotQ2 m n p)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _))) + -- ═══════ STAGE 3: THE TRANSPOSE AND SWAP ON THE INNER FOLD ═══════ + -- E3: the inner fold across the transpose and the swap. + have E3 : N₂.Equiv (XKH.relabel M₂) := + (Fragment.glueListCongr + (Fragment.relabelDisjUnionRight K H + (transposeEquiv n p)) _ _).trans + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv + ((K.disjUnion H).relabel sτ) + (mapPairs_symm_cancel sτ (interfacePairs m p n)).symm + (interfacePairs_wf m p n) + (Fragment.mapPairs_wf sτ _ + (Fragment.mapPairs_wf sτ.symm _ + (interfacePairs_wf m p n))) + ((mapPairs_symm_cancel sτ + (interfacePairs m p n)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListRelabel (K.disjUnion H) sτ + (Fragment.mapPairs sτ.symm (interfacePairs m p n)) + (Fragment.mapPairs_wf sτ.symm _ + (interfacePairs_wf m p n))).trans + ((Fragment.Equiv.relabelCongr + ((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 _ _ _))) + (Fragment.foldSurvivingMapEquiv sτ + (Fragment.mapPairs sτ.symm + (interfacePairs m p n)))).trans + (Fragment.Equiv.relabelTrans _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel sτ + (interfacePairs m p n)).symm ▸ + 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 + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv + ((F.disjUnion XKH).relabel + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (m + n))) M₂)) + (mapPairs_symm_cancel + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (m + n))) M₂) + (rotQ1 m n p)).symm + wfq1 + (Fragment.mapPairs_wf + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (m + n))) M₂) _ wfq2) + ((mapPairs_symm_cancel + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (m + n))) M₂) + (rotQ1 m n p)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListRelabel (F.disjUnion XKH) + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (m + n))) M₂) + (rotQ2 m n p) wfq2).trans + ((Fragment.Equiv.relabelCongr CR3 + (Fragment.foldSurvivingMapEquiv + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (m + n))) M₂) + (rotQ2 m n p))).trans + (Fragment.Equiv.relabelTrans _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (_root_.Equiv.sumCongr + (_root_.Equiv.refl (Fin (m + n))) M₂) + (rotQ1 m n p)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _))) + -- ═══════ STAGE 4: THE CLOSURE'S OWN INTERFACE ═══════ + -- E1: peel the closure casts and normalize the composite. + have E1 : ((F.relabel + (finCongr (by omega : m + n = 0 + (m + n)))).disjUnion + ((K.compose (H.relabel (transposeEquiv n p))).relabel + (finCongr (by omega : m + n = m + n + 0)))).Equiv + ((F.disjUnion N₂).relabel σR) := + (Fragment.relabelDisjUnionLeft F + ((K.compose (H.relabel (transposeEquiv n p))).relabel + (finCongr (by omega : m + n = m + n + 0))) + (finCongr (by omega : m + n = 0 + (m + n)))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.relabelDisjUnionRight F + (K.compose (H.relabel (transposeEquiv n p))) + (finCongr (by omega : m + n = m + n + 0))) + (_root_.Equiv.sumCongr + (finCongr (by omega : m + n = 0 + (m + n))) + (_root_.Equiv.refl _))).trans + ((Fragment.Equiv.relabelTrans _ _ _).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.Equiv.disjUnionCongr (Fragment.Equiv.refl F) + (composeNormal K (H.relabel (transposeEquiv n p)))).trans + (Fragment.relabelDisjUnionRight F N₂ + ((interfaceSurvEquiv m p n).trans finSumFinEquiv))) + ((_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 _)))).trans + (Fragment.Equiv.relabelTrans _ _ _)))) + -- CR1: transport the closure gluing. + have CR1 := (Fragment.glueListCongr E1 + (interfacePairs 0 (m + n) 0) + (interfacePairs_wf 0 (m + n) 0)).trans + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv ((F.disjUnion N₂).relabel σR) + (mapPairs_symm_cancel σR + (interfacePairs 0 (m + n) 0)).symm + (interfacePairs_wf 0 (m + n) 0) + (Fragment.mapPairs_wf σR _ wfq1) + ((mapPairs_symm_cancel σR + (interfacePairs 0 (m + n) 0)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListRelabel (F.disjUnion N₂) σR + (rotQ1 m n p) wfq1).trans + ((Fragment.Equiv.relabelCongr CR2 + (Fragment.foldSurvivingMapEquiv σR + (rotQ1 m n p))).trans + (Fragment.Equiv.relabelTrans _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel σR + (interfacePairs 0 (m + n) 0)).symm ▸ + List.Perm.refl _)).symm).trans + (Fragment.Equiv.relabelTrans _ _ _))) + -- ═══════ 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..55fc0863d8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotateLeft.lean @@ -0,0 +1,1466 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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) + show 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 + show 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 -/ + +/-- **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) := + Fragment.mapPairs_wf MR.symm _ wfq3 + 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.glueList UMB + (leftRotQ4 s t u) wfq4).Equiv + ((Fragment.glueList A + (mBlock s t u ++ + (pBlock s t u ++ + nBlockSwap s t u)) + (leftRotPairsR_wf s t u)).relabel + ((Fragment.appendFlatten _ _ + ((leftRotPairsR_wf s t u + ).append_sep)).symm.trans + (Fragment.foldSurvivingPermEquiv + ((leftRot_q4_eq s t u) ▸ + List.Perm.refl _ + )).symm)) := + (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 : A.Equiv + ((F.disjUnion + (W.disjUnion K)).relabel + (leftRotBridge s t u)) := + (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 : XR.Equiv (UMB.relabel MR) := + (Fragment.glueListCongr + (Fragment.Equiv.relabelFlip BE) + _ _).trans + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv + (A.relabel + (leftRotBridge s t u).symm) + (mapPairs_symm_cancel + (leftRotBridge s t u).symm + (Fragment.inrPairs + (α := Fin (t + u)) + (wkPairs s t u))).symm + (Fragment.inrPairs_wf _ + (wkPairs_wf s t u)) + (Fragment.mapPairs_wf + (leftRotBridge s t u).symm _ + wfground) + ((mapPairs_symm_cancel + (leftRotBridge s t u).symm + (Fragment.inrPairs + (α := Fin (t + u)) + (wkPairs s t u))).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListRelabel A + (leftRotBridge s t u).symm + ground wfground).trans + ((Fragment.Equiv.relabelCongr + (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 _))) + (Fragment.foldSurvivingMapEquiv + (leftRotBridge s t u).symm + ground)).trans + (Fragment.Equiv.relabelTrans + _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (leftRotBridge s t u).symm + (Fragment.inrPairs + (α := Fin (t + u)) + (wkPairs s t u))).symm ▸ + List.Perm.refl _ + )).symm).trans + (Fragment.Equiv.relabelTrans _ _ _))) + -- 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 + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv + (UMB.relabel MR) + (mapPairs_symm_cancel MR + (leftRotQ3 s t u)).symm + wfq3 + (Fragment.mapPairs_wf MR _ wfq4) + ((mapPairs_symm_cancel MR + (leftRotQ3 s t u)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListRelabel UMB MR + (leftRotQ4 s t u) wfq4).trans + ((Fragment.Equiv.relabelCongr + CRapp + (Fragment.foldSurvivingMapEquiv + MR + (leftRotQ4 s t u))).trans + (Fragment.Equiv.relabelTrans + _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel MR + (leftRotQ3 s t u)).symm ▸ + List.Perm.refl _ + )).symm).trans + (Fragment.Equiv.relabelTrans + _ _ _))) + -- E5: the embedded fold. + have E5 : + (F.disjUnion XWK).Equiv + (XR.relabel i') := + (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 + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv + (XR.relabel i') + (mapPairs_symm_cancel i' + (leftRotQ2 s t u)).symm + wfq2 + (Fragment.mapPairs_wf i' _ wfq3) + ((mapPairs_symm_cancel i' + (leftRotQ2 s t u)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListRelabel XR i' + (leftRotQ3 s t u) wfq3).trans + ((Fragment.Equiv.relabelCongr + CR5 + (Fragment.foldSurvivingMapEquiv + i' + (leftRotQ3 s t u))).trans + (Fragment.Equiv.relabelTrans + _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel i' + (leftRotQ2 s t u)).symm ▸ + List.Perm.refl _ + )).symm).trans + (Fragment.Equiv.relabelTrans + _ _ _))) + -- 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 : N₂.Equiv (XWK.relabel M₂) := + (Fragment.glueListCongr + (Fragment.relabelDisjUnionLeft + W K (transposeEquiv s t)) + _ _).trans + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv + ((W.disjUnion K).relabel sτ) + (mapPairs_symm_cancel sτ + (interfacePairs t s u)).symm + (interfacePairs_wf t s u) + (Fragment.mapPairs_wf sτ _ + (Fragment.mapPairs_wf sτ.symm _ + (interfacePairs_wf t s u))) + ((mapPairs_symm_cancel sτ + (interfacePairs t s u)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListRelabel + (W.disjUnion K) sτ + (Fragment.mapPairs sτ.symm + (interfacePairs t s u)) + (Fragment.mapPairs_wf sτ.symm _ + (interfacePairs_wf t s u + ))).trans + ((Fragment.Equiv.relabelCongr + (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 _))) + (Fragment.foldSurvivingMapEquiv + sτ + (Fragment.mapPairs sτ.symm + (interfacePairs t s u + )))).trans + (Fragment.Equiv.relabelTrans + _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel sτ + (interfacePairs t s u)).symm ▸ + 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 XWK M₂)) + (leftRotQ1 s t u) wfq1).trans + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv + ((F.disjUnion XWK).relabel + (_root_.Equiv.sumCongr + (_root_.Equiv.refl + (Fin (t + u))) M₂)) + (mapPairs_symm_cancel + (_root_.Equiv.sumCongr + (_root_.Equiv.refl + (Fin (t + u))) M₂) + (leftRotQ1 s t u)).symm + wfq1 + (Fragment.mapPairs_wf + (_root_.Equiv.sumCongr + (_root_.Equiv.refl + (Fin (t + u))) M₂) _ + wfq2) + ((mapPairs_symm_cancel + (_root_.Equiv.sumCongr + (_root_.Equiv.refl + (Fin (t + u))) M₂) + (leftRotQ1 s t u)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListRelabel + (F.disjUnion XWK) + (_root_.Equiv.sumCongr + (_root_.Equiv.refl + (Fin (t + u))) M₂) + (leftRotQ2 s t u) wfq2).trans + ((Fragment.Equiv.relabelCongr + CR3 + (Fragment.foldSurvivingMapEquiv + (_root_.Equiv.sumCongr + (_root_.Equiv.refl + (Fin (t + u))) M₂) + (leftRotQ2 s t u))).trans + (Fragment.Equiv.relabelTrans + _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel + (_root_.Equiv.sumCongr + (_root_.Equiv.refl + (Fin (t + u))) M₂) + (leftRotQ1 s t u)).symm ▸ + List.Perm.refl _ + )).symm).trans + (Fragment.Equiv.relabelTrans + _ _ _))) + -- 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 : + ((F.relabel (finCongr + (by omega : t + u = 0 + (t + u) + ))).disjUnion + (((W.relabel + (transposeEquiv s t)).compose + K).relabel (finCongr + (by omega : + t + u = t + u + 0)))).Equiv + ((F.disjUnion N₂).relabel σR) := + (Fragment.relabelDisjUnionLeft F + (((W.relabel + (transposeEquiv s t)).compose + K).relabel (finCongr + (by omega : t + u = t + u + 0))) + (finCongr + (by omega : + t + u = 0 + (t + u)))).trans + ((Fragment.Equiv.relabelCongr + (Fragment.relabelDisjUnionRight F + ((W.relabel + (transposeEquiv s t)).compose + K) + (finCongr + (by omega : + t + u = t + u + 0))) + (_root_.Equiv.sumCongr + (finCongr + (by omega : + t + u = 0 + (t + u))) + (_root_.Equiv.refl _))).trans + ((Fragment.Equiv.relabelTrans + _ _ _).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.Equiv.disjUnionCongr + (Fragment.Equiv.refl F) + (composeNormal + (W.relabel + (transposeEquiv s t)) K + )).trans + (Fragment.relabelDisjUnionRight + F N₂ + ((interfaceSurvEquiv t s u).trans + finSumFinEquiv))) + ((_root_.Equiv.sumCongr + (_root_.Equiv.refl + (Fin (t + u))) + (finCongr + (by omega : + t + u = t + u + 0))).trans + (_root_.Equiv.sumCongr + (finCongr + (by omega : + t + u = 0 + (t + u))) + (_root_.Equiv.refl _)))).trans + (Fragment.Equiv.relabelTrans + _ _ _)))) + -- CR1: transport the closure gluing. + have CR1 := + (Fragment.glueListCongr E1 + (interfacePairs 0 (t + u) 0) + (interfacePairs_wf 0 (t + u) 0 + )).trans + ((Fragment.Equiv.relabelFlip' + (Fragment.glueListEqEquiv + ((F.disjUnion N₂).relabel σR) + (mapPairs_symm_cancel σR + (interfacePairs 0 + (t + u) 0)).symm + (interfacePairs_wf 0 (t + u) 0) + (Fragment.mapPairs_wf σR _ + wfq1) + ((mapPairs_symm_cancel σR + (interfacePairs 0 + (t + u) 0)).symm ▸ + List.Perm.refl _))).trans + ((Fragment.Equiv.relabelCongr + ((Fragment.glueListRelabel + (F.disjUnion N₂) σR + (leftRotQ1 s t u) wfq1).trans + ((Fragment.Equiv.relabelCongr + CR2 + (Fragment.foldSurvivingMapEquiv + σR + (leftRotQ1 s t u))).trans + (Fragment.Equiv.relabelTrans + _ _ _))) + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel σR + (interfacePairs 0 + (t + u) 0)).symm ▸ + List.Perm.refl _ + )).symm).trans + (Fragment.Equiv.relabelTrans + _ _ _))) + -- 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. -/ +private theorem 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)) + (liftPairs_map_swap ps qs _ _) + +/-- Permutation from rotatePairsL to the +intermediate form mBlock ++ (pBlock ++ nBlock). -/ +private theorem leftRotPairs_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 -/ + +/-- **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 + (leftRotPairs_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) := + hassocM ▸ wf_M + 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 := + 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 + (leftRotPairs_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..12dda4aab3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseUnion.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseTensor +import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity +import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic +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)). +-/ + +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))))) + show 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..c132b1b6f2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedAgreement.lean @@ -0,0 +1,255 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon +import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists +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. +-/ + +namespace RS + +open scoped Classical + +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 + show 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 + 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 [if_pos (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 [if_pos (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..1dcc58b2ab --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedCutDispatch.lean @@ -0,0 +1,272 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge +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. +-/ + +namespace RS + +open scoped Classical +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 => + show (κ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..49f2f16b26 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedIdentify.lean @@ -0,0 +1,211 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceCut +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Classical + +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⟩⟩] + show (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 (dif_pos hc) (Eq.trans ?_ (dif_pos hc).symm) + refine Eq.trans ?_ (dif_pos 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 (if_pos hE') (Eq.trans ?_ (if_pos hE).symm) + refine Eq.trans ?_ (dif_pos 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 (if_neg hE') ?_ + exact (if_neg hE).symm + · refine Eq.trans (dif_neg hc) ?_ + symm + exact dif_neg 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..4f5cf6050c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.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 +-/ + +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Classical + +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 [dif_pos hc, dif_pos hE, dif_pos 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 + 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..855723c541 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourEmbedding.lean @@ -0,0 +1,175 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition +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. +-/ + +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)) + +private 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ℓ) + (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..9055fec0f1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean @@ -0,0 +1,1970 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Classical + +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 [if_pos hm, if_pos ((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 [if_neg hm, if_neg (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 [if_pos hg, if_pos ((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 [if_neg hg, if_neg (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 [if_pos hg, Finset.sum_eq_single + (ψ'.val ⟨partnerSurvI hopen, hni⟩) + (fun a _ hne => if_neg (fun hx => hne hx.1.symm)) + (fun hx => absurd (Finset.mem_univ _) hx), if_pos ⟨rfl, hg⟩] + rfl + · rw [if_neg hg] + exact Finset.sum_eq_zero (fun a _ => if_neg (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⟩ := dif_pos 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 [dif_neg (fun hEq => hij (V.boundaryFlag_injective hEq).symm), + dif_pos 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 [dif_neg g.prop.1, dif_neg 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] + show _ = 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 φ'] + show _ = 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 => ?_) + show 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') + +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 [if_neg (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 [if_pos hg, if_pos ((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 [if_pos ((edgeOddBoundaryMatch_hit_iff hij hopen t hct + hcL hpi st' d φ').mpr hp), if_pos 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 [if_neg (fun hx => hp ((edgeOddBoundaryMatch_hit_iff hij + hopen t hct hcL hpi st' d φ').mp hx)), if_neg hp] + · rw [if_neg hg, if_neg (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 [if_pos 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 [if_pos hp, Finset.sum_eq_single + (φ'.val ⟨partnerSurvI hopen, hpi⟩) + (fun d _ hne => if_neg (fun hx => hne hx.1.symm)) + (fun hx => absurd (Finset.mem_univ _) hx), if_pos ⟨rfl, hp⟩] + rfl + · rw [if_neg hp] + exact Finset.sum_eq_zero (fun d _ => if_neg (fun hx => hp hx.2)) + · simp only [if_neg 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 := dif_pos 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 [dif_neg (fun hEq => hij (V.boundaryFlag_injective hEq).symm), + dif_pos 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 [dif_neg g.prop.1, dif_neg 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 => ?_) + show 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 [if_neg (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 [if_pos ((genEvenBoundaryMatch_closedFalse_iff hij hclosed t + hct hcL st' a hbndW hbnd' ψ').mpr hg), if_pos 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 [if_pos hm, if_pos ((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 [if_neg hm, if_neg (fun hx => hm + ((edgeOddBoundaryMatch_closedFalse hij hclosed t hct hcL st' + a φ).mpr hx))] + · rw [if_neg (fun hx => hg ((genEvenBoundaryMatch_closedFalse_iff + hij hclosed t hct hcL st' a hbndW hbnd' ψ').mp hx)), + if_neg 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 := dif_pos 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 [dif_neg (fun hEq => hij (V.boundaryFlag_injective hEq).symm), + dif_pos 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 [dif_neg g.prop.1, dif_neg 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 => ?_) + show 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 [if_neg (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 [if_pos hg, if_pos ((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 [if_pos hp, if_pos ((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 [if_neg hp, if_neg (fun hx => hp + ((edgeOddBoundaryMatch_closedTrue_iff hij hclosed t hct hcT + st' d φ').mp hx))] + · rw [if_neg hg, if_neg (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..850ccca486 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean @@ -0,0 +1,259 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourEmbedding +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. +-/ + +namespace RS + +open Classical + +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 [EdgeSubset.oddPairFn, oddColouring, e.partner_eq] + +/-- 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..0b6fddf0e6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourRecursion.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeTerm +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Classical + +/-! ## 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 [dif_pos 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 [dif_neg 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 [dif_neg 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 [dif_pos 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 [dif_pos 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 [dif_pos 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⟩)] + show _ = 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 ?_) + show (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 ?_) + show (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 [if_pos 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 + show (if hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then _ else _) = _ + rw [dif_neg 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 + show (if hc : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then _ else _) = _ + rw [dif_pos 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 α] [DecidableEq α] + (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 + show (if hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then _ else _) = _ + exact dif_neg 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 + show (if hc : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then _ else _) = _ + exact dif_pos 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 + show (if hcl : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then _ else _) = _ + rw [dif_neg 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 + show (if hc : V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then _ else _) = _ + rw [dif_pos 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 + show (if V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then 1 else 0) + + closedCuts n (stepFragment n V) = _ + rw [if_pos 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 + show (if V.pairing (V.boundaryFlag (cutL n)) + = V.boundaryFlag (cutR n) then 1 else 0) + + closedCuts n (stepFragment n V) = _ + rw [if_neg 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..6bc6866557 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeAssoc.lean @@ -0,0 +1,1192 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + · show ((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 + · show (((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 + · show (((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 + show 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 + · show ((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 + · show ((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 + · show ((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 + · show ((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 show 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 show t ≤ t + k; omega)) + rw [finSumFinEquiv_apply_right] at h3 + exact h3.trans (Fin.ext (by show 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 + +/-! ### 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))) + +/-- **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'' := + Fragment.mapPairs_wf i.symm _ wfps' + 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.glueList X ps'' wfps'').Equiv + ((Fragment.glueList A + (Fragment.inlPairs (interfacePairs s t u) ++ + uPairsAssoc s t u v) + (assocPairs_wf s t u v)).relabel + ((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)) := + (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 : (N₁.disjUnion H).Equiv (X.relabel i) := + (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 : ((F.compose G).disjUnion H).Equiv + ((N₁.disjUnion H).relabel σ) := + (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) + +/-- 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))))))))))) + +/-- **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) := + Fragment.mapPairs_wf σ'.symm _ (interfacePairs_wf s t 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) := + Fragment.mapPairs_wf (rhsBridgeEquiv s t u v).symm _ wfqs2 + 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 : YR.Equiv + ((Fragment.glueList A + (Fragment.inlPairs (interfacePairs s t u) ++ + uPairsAssoc s t u v) + (assocPairs_wf s t u v)).relabel + ((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)) := + (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.glueList UPA (rhsQs3 s t u v) wfqs3).Equiv + ((Fragment.glueList A + (Fragment.inlPairs (interfacePairs s t u) ++ + uPairsAssoc s t u v) + (assocPairs_wf s t u v)).relabel + (((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))) := + (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 : XR.Equiv (UPA.relabel (rhsBridgeEquiv s t u v)) := + (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.glueList XR (rhsQs2 s t u v) wfqs2).Equiv + ((Fragment.glueList UPA (rhsQs3 s t u v) wfqs3).relabel + ((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)) := + (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 : (F.disjUnion N₂).Equiv (XR.relabel i') := + (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.glueList (F.disjUnion N₂) + (rhsQs1 s t u v) wfqs1).Equiv + ((Fragment.glueList XR (rhsQs2 s t u v) wfqs2).relabel + ((Fragment.foldSurvivingMapEquiv i' (rhsQs2 s t u v)).trans + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel i' (rhsQs1 s t u v)).symm ▸ + List.Perm.refl _)).symm)) := + (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 : (F.disjUnion (G.compose H)).Equiv + ((F.disjUnion N₂).relabel σ') := + (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.glueList (F.disjUnion (G.compose H)) + (interfacePairs s t v) (interfacePairs_wf s t v)).Equiv + ((Fragment.glueList (F.disjUnion N₂) + (rhsQs1 s t u v) wfqs1).relabel + ((Fragment.foldSurvivingMapEquiv σ' (rhsQs1 s t u v)).trans + (Fragment.foldSurvivingPermEquiv + ((mapPairs_symm_cancel σ' + (interfacePairs s t v)).symm ▸ + List.Perm.refl _)).symm)) := + (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 show 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..db976d683e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeNormal.lean @@ -0,0 +1,596 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show 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 + show ¬ t + b.val < t + omega⟩ + left_inv b := Subtype.ext (Fin.ext (by + have := Nat.le_of_not_lt b.prop + show t + (b.val.val - t) = b.val.val + omega)) + right_inv b := Fin.ext (by + show 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] + show (if a.val < s + t then a.val else a.val - 1) = a.val + rw [if_pos 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] + show (if b.val < t then b.val else b.val - 1) = b.val + rw [if_pos 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] + show (if b.val < t then b.val else b.val - 1) = b.val - 1 + rw [if_neg (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 show 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 + show (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 + show (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⟩) + (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 show 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⟩) + (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 show 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 + show 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 _)).trans + ((Fragment.foldSurvivingPermEquiv + (by rw [interfacePairs_succ s t u] : + (interfacePairs s (t + 1) u).Perm _)).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 _ _ _) + show ((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..4ac1515de3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeRelabel.lean @@ -0,0 +1,248 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose +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. +-/ + +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 show 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) + show 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 + · show 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 show 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 show ¬ (outPermEquiv t σ b).val < t + rw [hbv] + show ¬ t + (σ ⟨b.val - t, hj⟩).val < t + omega)) + show 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]; show 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 ?_ + show (outPermEquiv t σ b).val - t = (σ ⟨b.val - t, hj⟩).val + rw [hbv] + show 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..adfed76361 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/Composition.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 +-/ + +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. +-/ + +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 [if_pos 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 [if_neg (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 [if_pos hc] at h + rw [if_pos (by omega)] + omega + · rw [if_neg hc] at h + rw [if_neg (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, if_pos (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..844d0f2817 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CompositionEquiv.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 +-/ + +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. +-/ + +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..e0aead1148 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConnectionRank.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 +-/ + +import LeanPool.RegtsSevenster.RS.Common.RowSpanRank +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`). +-/ + +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..3b0c8ff2f3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseAssembly.lean @@ -0,0 +1,2026 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.RSTensor +import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedIdentify +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Classical + +/-- 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 [dif_pos hc, dif_pos hE, dif_pos 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 ?_ + show 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 dif_pos 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 dif_neg 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, dif_pos 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 [if_pos hm] + exact congrArg₂ (· + ·) (if_pos 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 [if_neg hm] + exact congrArg₂ (· + ·) (if_neg hb).symm hstep + · rw [stepData_sub_flags_open n V D hcl] at hstep + simp only [carried, glueCount, dif_neg 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₂ (· + ·) (if_neg 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 ?_ + show 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 ?_ + show 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} [LinearOrder γ] + [LinearOrder δ] [Fintype γ] [Fintype δ] + [LinearOrder (γ ⊕ δ)] {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 + show (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 + show (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 + show ((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 + show ((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] + show (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 + show 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 [if_pos (κ.match_mem f hf), if_pos hf] + exact o.match_flip f hf + pairing_flip f hf hp := by + rw [if_pos hp, if_pos 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} [LinearOrder α] + {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 := if_pos hf + +open Classical in +/-- Off the internal flags the replacement is the given function. -/ +theorem isOut_orientReplace_of_not_internal {α : Type} + [LinearOrder α] {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 := if_neg 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 [dif_pos hc, dif_pos hbnd, if_pos hE, dif_pos 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 [dif_pos hc, dif_pos hbnd, if_pos hE, dif_neg hne, + edgeTermAt_eq_zero_of_not_canon h 𝒟 st hc hne 0, + mul_zero] + · rw [dif_pos hc, dif_pos hbnd, if_neg hE, + edgeTermAt_eq_zero_of_not_eulerian h 𝒟 st hc hE 0, + mul_zero] + · rw [dif_pos hc, dif_neg hbnd, + edgeTermAt_eq_zero_of_not_matches h 𝒟 st hbnd 0, mul_zero] + · rw [dif_neg 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 + show (if IsThroughLabel F i.val then + decide (i.val < chordInv F κ i.val) + else !chainDir o (W.boundaryFlag i.val)) = _ + rw [if_neg 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 [dif_pos 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 [dif_pos 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 [dif_pos 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 [dif_pos 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..b46899ef94 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseDischarge.lean @@ -0,0 +1,28 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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..41854bbd2b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseFamily.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 +-/ + +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Classical + +/-- 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 [dif_pos hm₁, dif_neg 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 => + show 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 => + show 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 dif_neg 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 + show (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 dif_pos 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 dif_neg 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) + +-- Raised budget: 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 dif_pos 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] + show 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 + show (∑ 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, if_neg (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, if_pos 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 + show (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 + show 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 [dif_neg 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 [dif_pos hc, dif_neg 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 [dif_pos hc, dif_pos hE, dif_neg 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..947cb08327 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseGram.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.RSTensor +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`. +-/ + +namespace RS + +open Classical + +/-- **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..0a2bb5fff9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseIdentity.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseFamily +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`. +-/ + +namespace RS + +open scoped Classical + +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 + show 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..c7c37b76da --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseLift.lean @@ -0,0 +1,724 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseAssembly +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Classical + +/-- 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 [dif_neg hop, dif_neg 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 [dif_pos hcl, dif_pos 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 + show unglueMatch κ₁.match_ f = unglueMatch κ₂.match_ f + unfold unglueMatch + rw [dif_pos ⟨h1, h2⟩, dif_pos ⟨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 + show unglueMatch κ₁.match_ f = unglueMatch κ₂.match_ f + unfold unglueMatch + rw [dif_pos ⟨h1, h2⟩, dif_pos ⟨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 [dif_pos hag, dif_pos 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 [dif_neg hag, dif_neg 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 [dif_neg hop, dif_neg 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 [dif_pos hcl, dif_pos 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 + show (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) + +-- Raised budget: 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..b0d1483a6b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConversePair.lean @@ -0,0 +1,1087 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Classical + +/-- 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 [dif_neg h, dif_neg 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 [dif_pos 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 [dif_neg hno, dif_pos 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} [LinearOrder α] + {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] + show 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] + show 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} [LinearOrder α] [Fintype α] + {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} [LinearOrder α] + {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 α] + [Fintype α] {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} [LinearOrder α] {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..8696e8d69a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseTrip.lean @@ -0,0 +1,1617 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Classical + +/-- 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 [dif_pos hag, dif_pos 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 [dif_neg hag, dif_neg 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 [dif_neg hop, dif_neg 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 [dif_pos hcl, dif_pos 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} [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') + {κ₁ κ₂ : (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} [LinearOrder α] + {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} [LinearOrder α'] + [LinearOrder β'] (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 [dif_pos (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 [dif_neg hop, relabelDataUp_dataOfEq] + rfl + revert hct hEt hnet + rw [show stepData n V D = _ from dif_neg 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 [dif_pos hcl, relabelDataUp_dataOfEq] + rfl + revert hct hEt hnet + rw [show stepData n V D = _ from dif_pos 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 [dif_neg 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 [dif_pos 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} [LinearOrder α] {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] + show 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] + show 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 [dif_neg h1, dif_neg 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 [dif_pos 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 [dif_neg (fun hx => cutL_ne_cutR n + (V.boundaryFlag_injective hx).symm), dif_pos 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 [dif_neg h1, dif_neg 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 [dif_pos 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 [dif_neg (fun hx => cutL_ne_cutR n + (V.boundaryFlag_injective hx).symm), dif_pos 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..b927f3c352 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CrossingDelta.lean @@ -0,0 +1,714 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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). +-/ + +namespace RS + +open scoped Classical + +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⟩ + +/-- 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 [if_pos ⟨huw, hxy, hux, hxw, hwy⟩, if_neg h2, + if_pos ⟨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 [if_neg h1, if_pos ⟨hxy, huw, hxu, huy, hyw⟩, + if_pos ⟨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 [if_neg h1, if_neg h2, if_neg h3] + +/-- 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 := + if_neg (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 := + if_neg (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 := + if_neg (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 := + if_neg (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 + +/-- **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 + +/-- 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 + +/-- 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 := + if_neg fun h => by + obtain ⟨-, -, hlt, -, -⟩ := (chordCross_iff_labels _ _).mp h + exact lt_irrefl _ hlt + +/-- 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 if_neg (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) + +/-- **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)) + +/-- **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)) + +/-- **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 := + if_neg (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 := + if_neg (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 := + if_neg (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 := + if_neg (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] + +/-- **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..0c8790dc63 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean @@ -0,0 +1,955 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.DirMatching +import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonicalFrame +import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordCount +import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperSpace +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. +-/ + +namespace RS + +open Classical 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 + +/-- **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 + show (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 [if_pos ht', if_pos 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 + show (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 [if_neg ht', if_neg 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 [dif_pos hb', dif_pos 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 [dif_neg hb', dif_neg 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 + show 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)) + show (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 [if_pos hnt, if_neg (fun hx => hj (hcond.mp hx))] + show _ = if IsThroughLabel F j.val then + decide (j.val < chordInv F κ j.val) else _ + rw [if_pos hnt] + · have htail : (cutMatching F κ o).tail j + = !chainDir o (W.boundaryFlag j.val) := by + show (if IsThroughLabel F j.val then + decide (j.val < chordInv F κ j.val) else _) = _ + rw [if_neg hnt] + rw [if_neg 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 [if_pos (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 [if_neg (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 := + dif_pos 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 := + dif_neg 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, if_pos] + 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, if_neg] + 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, if_neg (by simp), if_pos rfl] + rcases hx : x i with a | c + · rfl + · show 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, if_pos rfl, + if_neg (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 [dif_pos hb, dif_pos hb, + tail_portFlip_of_not_mem o h hb₁ hchord hb hj] + by_cases ht : (cutMatching F κ o).tail ⟨i, hb⟩ = true + · rw [if_pos ht] + exact dualFactor_sq (x i) + · rw [if_neg ht] + norm_num + · rw [dif_neg hb, dif_neg hb] + norm_num + rw [← Finset.prod_subset (Finset.subset_univ ({i₁, i₂} : + Finset α)) hpair, Finset.prod_pair hne, + dif_pos hb₁, dif_pos hb₂, dif_pos hb₁, dif_pos 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 [if_pos ht, if_pos ht] + · rw [if_neg ht, if_neg 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 [dif_pos hb, dif_pos hb, + show (M.reverseArc a).tail ⟨i, hb⟩ = M.tail ⟨i, hb⟩ from by + rw [DirMatching.reverseArc_tail] + exact if_neg (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 [if_pos ht] + exact dualFactor_sq (x i) + · rw [if_neg ht] + norm_num + · rw [dif_neg hb, dif_neg 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 [dif_pos a.prop, dif_pos a.prop, dif_pos (M.edge a).prop, + dif_pos (M.edge a).prop] + rw [show (M.reverseArc a).tail ⟨a.val, a.prop⟩ = false from by + rw [ha, DirMatching.reverseArc_tail, if_pos (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, if_pos (Or.inr rfl), htb] + rfl, + show M.tail ⟨(M.edge a).val, (M.edge a).prop⟩ = false from by + rw [ha']; exact htb] + rw [if_neg (by simp), if_pos rfl, if_pos rfl, if_neg (by simp), + hca, hca'] + show (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 [dif_pos hb] + by_cases ht : tl ⟨i, hb⟩ = true + · rw [if_pos ht, if_pos ht] + rcases x i with a | c <;> rfl + · rw [if_neg ht, if_neg 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 := dif_neg 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 + · show 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 if_pos (Or.inl (Subtype.ext rfl))] + by_cases ht : M.tail ⟨a.val, a.prop⟩ = true + · rw [ht, Bool.not_true, if_neg (by simp), if_pos 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, if_pos rfl, if_neg (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 if_pos (Or.inr (Subtype.ext rfl))] + by_cases ht : M.tail ⟨(M.edge a).val, (M.edge a).prop⟩ = true + · rw [ht, Bool.not_true, if_neg (by simp), if_pos 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, if_pos rfl, if_neg (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 if_neg (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 [dif_pos hb] + by_cases ht : tl ⟨i, hb⟩ = true + · rw [if_pos ht] + exact dualFactor_sq (x i) + · rw [if_neg ht] + norm_num + · rw [dif_neg 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 [if_pos 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 [if_neg 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 [dif_pos hb] + by_cases ht : (cutMatching F κ o).tail ⟨i, hb⟩ = true + · rw [if_pos ht] + exact dualFactor_sq (x i) + · rw [if_neg ht] + norm_num + · rw [dif_neg 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..d25e334f53 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CutSubsetSum.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 +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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 [dif_pos 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 [dif_neg (Ne.symm hij), dif_pos 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 [dif_neg x.prop.1, dif_neg 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..ea5997f84d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DirMatching.lean @@ -0,0 +1,2220 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OrbitCard +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. +-/ + +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 [if_pos ha, M.tail_flip a] + · rw [if_neg 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 [if_pos ha, if_neg (by rw [M.tail_flip a, ha]; simp), + M.edge_invol] + · rw [if_neg ha, if_pos (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 [if_pos ha, if_neg (by rw [tail_edge_alt h a, ha]; simp), + N.edge_invol] + · rw [if_neg ha, if_pos (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] + show M.rot N a = M.edge a + rw [rot, if_pos ha]⟩ + · exact ⟨-1, by + show (M.rotPerm N h ^ (-1 : ℤ)) a = M.edge a + rw [zpow_neg, zpow_one] + show (M.rotPerm N h).symm a = M.edge a + show M.rotInv N a = M.edge a + rw [rotInv, if_neg 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] + show (M.rotPerm N h).symm a = N.edge a + show M.rotInv N a = N.edge a + rw [rotInv, if_pos ha]⟩ + · exact ⟨1, by + show (M.rotPerm N h ^ (1 : ℤ)) a = N.edge a + rw [zpow_one] + show M.rot N a = N.edge a + rw [rot, if_neg ha]⟩ + +/-- **A directed perfect matching forces an even ground set**: the +partner map exchanges the tails with the heads. -/ +theorem even_card [Fintype α] [DecidableEq α] (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_setOf_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_setOf_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 α] [DecidableEq α] + (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 [if_pos ha, M.edge_invol, + if_neg (by rw [tail_edge_alt h a, ha]; simp), N.edge_invol] + · rw [if_neg ha, if_pos (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 + show σ (τ.symm (M.edge a)) = M.edge (σ (τ.symm a)) + rw [hτ.edge_symm a, hσ.edge] + · intro a + show 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 [dif_pos h, dif_pos 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 [dif_neg h, dif_neg 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 [dif_pos h, dif_pos 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 [dif_neg h, dif_neg 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 [Fintype α] [DecidableEq α] + (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 + show (if h' : N.tail (N.edge a) = true then _ else _) = _ + rw [dif_neg hne] + show M.edge (b ⟨N.edge (N.edge a), _⟩).val + = M.edge (if h' : N.tail a = true then (b ⟨a, h'⟩).val else _) + rw [dif_pos 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 + show (if h' : N.tail (N.edge a) = true then (b ⟨N.edge a, h'⟩).val + else _) = _ + rw [dif_pos hne] + show _ = M.edge (if h' : N.tail a = true then _ + else M.edge (b ⟨N.edge a, _⟩).val) + rw [dif_neg h, M.edge_invol] + · intro a + by_cases h : N.tail a = true + · show M.tail (if h' : N.tail a = true then (b ⟨a, h'⟩).val else _) + = N.tail a + rw [dif_pos h, h] + exact (b ⟨a, h⟩).prop + · have hne : N.tail (N.edge a) = true := by + rw [N.tail_flip]; simpa using h + show M.tail (if h' : N.tail a = true then _ + else M.edge (b ⟨N.edge a, _⟩).val) = N.tail a + rw [dif_neg 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 [Fintype α] [DecidableEq α] (M N : DirMatching α) : + ∃ σ : Equiv.Perm α, Carries M N σ := by + 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 + show σ (τ (P.edge a)) = M.edge (σ (τ a)) + rw [hτ.edge a, hσ.edge (τ a)] + · intro a + show 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 + show 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 [if_pos h, + if_neg (show ¬ ((i.val + 1) % 2 = 0) by omega)] + omega + · simp only [if_neg h, + if_pos (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 + · show decide ((⟨if i.val % 2 = 0 then i.val + 1 else i.val - 1, + _⟩ : Fin (2 * m)).val % 2 = 0) = _ + simp only [if_pos h] + rw [decide_eq_false (show ¬ ((i.val + 1) % 2 = 0) by omega), + decide_eq_true h] + rfl + · show decide ((⟨if i.val % 2 = 0 then i.val + 1 else i.val - 1, + _⟩ : Fin (2 * m)).val % 2 = 0) = _ + simp only [if_neg 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 + show 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 + show 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 [if_pos (Or.inr rfl), if_pos (Or.inl rfl), M.tail_flip, + Bool.not_not] + · by_cases h2 : b = M.edge a + · subst h2 + rw [if_pos (Or.inl (M.edge_invol a)), + if_pos (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 [if_neg h3, if_neg (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 + show σ (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 + show R.tail (σ (Equiv.swap a (M.edge a) b)) + = (M.reverseArc a).tail b + rw [hσ.tail] + show 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, if_pos (Or.inl rfl), M.tail_flip] + · by_cases h2 : b = M.edge a + · subst h2 + rw [Equiv.swap_apply_right, if_pos (Or.inr rfl), + M.tail_flip, Bool.not_not] + · rw [Equiv.swap_apply_of_ne_of_ne h1 h2, + if_neg (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 α] [DecidableEq α] + {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 [if_pos 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 [if_neg 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 + show 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] + show (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 + show N.edge ((p ^ i) a) = N.edge (M.edge (M.edge ((p ^ i) a))) + rw [M.edge_invol] + rw [h2, hstep i] + show 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 [Fintype α] [DecidableEq α] + (M N : DirMatching α) : + ∃ M' N' : DirMatching α, + M'.edge = M.edge ∧ N'.edge = N.edge ∧ Alternating M' N' := by + classical + 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 + show 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] + show 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 + show 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 [if_neg 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 [if_pos 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 [if_neg (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 [if_neg (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 [if_pos 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 [if_neg h1, if_pos h2] + exact ⟨M.edge_ne i, hopen⟩ + · rw [if_neg h1, if_neg 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 [if_pos h1, if_neg (by rw [M.edge_invol]; exact Ne.symm hij), + if_pos (by rw [M.edge_invol])] + rw [← h1, M.edge_invol] + · by_cases h2 : M.edge x = j + · rw [if_neg h1, if_pos h2, if_pos (by rw [M.edge_invol])] + rw [← h2, M.edge_invol] + · rw [if_neg h1, if_neg h2, + if_neg (by rw [M.edge_invol]; exact hx), + if_neg (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 [if_pos 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 [if_neg h1, if_pos h2] + intro hx + refine hij ?_ + rw [← hx] at h2 + rwa [M.edge_invol] at h2 + · rw [if_neg h1, if_neg 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 + show M.tail (M.contractEdge i j x.val) = !M.tail x.val + unfold contractEdge + by_cases h1 : M.edge x.val = i + · rw [if_pos 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 [if_neg h1, if_pos h2, M.tail_flip i] + have hxx := M.tail_flip x.val + rw [h2, hdir] at hxx + exact hxx + · rw [if_neg h1, if_neg 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 + show ((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 [if_pos (show (M.contract hij hopen + (tail_ne_of_alternating h hN)).tail x = true from hx), + if_pos hx] + rfl + · rw [if_neg (show ¬ ((M.contract hij hopen + (tail_ne_of_alternating h hN)).tail x = true) from hx), + if_neg hx] + rfl + rw [hval] + by_cases hx : M.tail x.val = true + · rw [if_pos hx] + unfold contractEdge + by_cases h1 : M.edge x.val = i + · rw [if_pos 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 [if_neg h1, if_pos 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 [if_neg h1, if_neg h2] + exact sameCycle_rot_edge h x.val + · rw [if_neg 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 + show ((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 [if_pos (show (M.contract hij hopen + (tail_ne_of_alternating h hN)).tail x = true from hx), + if_pos hx] + rfl + · rw [if_neg (show ¬ ((M.contract hij hopen + (tail_ne_of_alternating h hN)).tail x = true) from hx), + if_neg 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 [if_pos hx] at hs hs' + rw [if_pos hx, if_pos hx] + unfold contractEdge + rw [if_neg hs, if_neg hs'] + · rw [if_neg hx] at hs hs' + rw [if_neg hx, if_neg 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 [if_neg 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 [if_pos hx] + rw [rot_contract_val h hij hN hopen x, if_pos 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 [if_pos hs, hrot, hs] + have h1 : M.rot N i = j := by + unfold rot; rw [if_neg (by rw [hti]; exact Bool.noConfusion), hN] + have h2 : M.rot N j = M.edge j := by + unfold rot; rw [if_pos 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 [if_neg (fun hxi => hij (hxi.symm.trans hs)), if_pos hs, + hrot, hs] + have h1 : M.rot N j = i := by + unfold rot; rw [if_neg (by rw [htj]; exact Bool.noConfusion), hNj] + have h2 : M.rot N i = M.edge i := by + unfold rot; rw [if_pos 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 [dif_pos ha] + · rw [dif_neg 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 [Fintype α] [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 + 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 [dif_pos x.prop] + show 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 [if_pos hb, hM] + · rw [if_neg hb, hN] + · unfold rot + by_cases hb : M.tail j = true + · rw [if_pos hb, hMj] + · rw [if_neg 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 [if_pos hb] + exact key M hM hMj + · rw [if_neg 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 + show ((M.restrict hM).rot (N.restrict hN) x).val = _ + unfold rot + by_cases hb : M.tail x.val = true + · rw [if_pos (show (M.restrict hM).tail x = true from hb), + if_pos hb] + rfl + · rw [if_neg (show ¬ ((M.restrict hM).tail x = true) from hb), + if_neg hb] + rfl + +/-- The identified pair is invariant under the rotation, and so is +its complement. -/ +theorem rot_surviving_iff [DecidableEq α] (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 ?_⟩ + · show M.rot N x = j + rw [hx]; exact hi + · show 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 ?_ + show 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 [if_pos ha, show P₁.edge a = P₂.edge a from by rw [hP]] + exact sameCycle_rot_edge k₂ a + · rw [if_neg 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 => ?_) + show (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 [if_pos hb, if_pos hb] + · rw [if_neg hb, if_neg 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 [if_neg (fun hc => hx' (((M.edge_invol x).symm.trans + (congrArg M.edge hc)).trans hM)), + if_neg (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 + show (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 + · show (!B₁.tail (e.symm (e a))) = !(!A₁.tail a) + rw [e.symm_apply_apply, h a, Bool.not_not] + · show (!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, if_pos ha]] + show (if A₁.tail a = true then (Sum.inl (A₁.edge a) : γ ⊕ δ) + else Sum.inr (e a)) = Sum.inl (A₁.edge a) + rw [if_pos 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] + show (if A₁.tail a = true then (Sum.inl (A₁.edge a) : γ ⊕ δ) + else Sum.inr (e a)) = Sum.inr (e a) + rw [if_neg ha] + have h2 : π (Sum.inr (e a)) = Sum.inr (e (B₁.edge a)) := by + rw [hstep] + show (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, if_pos hb] + have h3 : π (Sum.inr (e (B₁.edge a))) = Sum.inl (B₁.edge a) := by + rw [hstep] + show (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, if_neg (by rw [hb2]; exact Bool.noConfusion)] + have : (π ^ (3 : ℕ)) (Sum.inl a) = Sum.inl (B₁.edge a) := by + show π (π (π (Sum.inl a))) = Sum.inl (B₁.edge a) + rw [h1, h2, h3] + rw [show ((3 : ℤ)) = ((3 : ℕ) : ℤ) from rfl, zpow_natCast, this, + rot, if_neg 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] + show 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 [if_pos ha, rot, if_pos ha] + rfl + · refine ⟨0, ?_⟩ + rw [zpow_zero, hstep] + show 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 [if_neg 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] + show 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 [if_pos hb, rot, if_neg ha] + exact (e.symm_apply_apply _).symm + · refine ⟨0, ?_⟩ + rw [zpow_zero, hstep] + show 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 [if_neg 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] + show (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 [if_neg (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] + show (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 [if_neg ha, e.apply_symm_apply] + +/-- **The union on two copies counts what the union on one copy +counts.** -/ +theorem unionCount_sumMatching + [Fintype γ] [DecidableEq γ] [Fintype δ] [DecidableEq δ] (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 ?_ + show e (B₁.edge (e.symm b)) = M₂.edge b + rw [congrFun hBe (e.symm b)] + show 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..883194412b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjSubsetSplit.lean @@ -0,0 +1,259 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +namespace RS + +variable {α β : Type} {W₁ : Fragment α} {W₂ : Fragment β} + +open scoped Classical + +/-! ## 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 + show (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 + show (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 + show (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 + show (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..c4da248e78 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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..3b90160fb0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean @@ -0,0 +1,762 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.SumLexOrder +import LeanPool.RegtsSevenster.RS.Novel.Skein.InvolutionCard +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjSubsetSplit +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. +-/ + +namespace RS + +open scoped Classical + +/-! ## Membership characterizations (any fragment) -/ + +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 + show (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 + show (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 + show (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 + show (W₁.attach f).map Sum.inl Sum.inl ≠ Sum.inl (Sum.inr v) + rcases W₁.attach f with w | ℓ <;> simp + +private 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⟩ + +private 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 + show (∃ 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 + show (∃ 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 + show κ.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 ?_) + show 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 -/ + +private noncomputable def leftDescend (κ : F.RelTransitionSystem) + (g : W₁.Flag) : W₁.Flag := + Sum.elim id (fun _ => g) (κ.match_ (Sum.inl g)) + +private noncomputable def rightDescend (κ : F.RelTransitionSystem) + (g : W₂.Flag) : W₂.Flag := + Sum.elim (fun _ => g) id (κ.match_ (Sum.inr g)) + +private 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 + +private 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 + +private 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 + +private 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 := 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 := 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 => + show Sum.inl (κ₁.match_ (κ₁.match_ g)) = Sum.inl g + rw [κ₁.match_invol g (inl_mem_internal.mp hf)] + | inr g => + show 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 => + show o₁.isOut (κ₁.match_ g) = !o₁.isOut g + exact o₁.match_flip g (inl_mem_internal.mp hf) + | inr g => + show 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 => + show 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 => + show 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 + +private 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] + +private 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] + +private 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 + +private 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..053e364083 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean @@ -0,0 +1,735 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +section ColourSplit + +open EdgeSubset + +variable {α β : Type} {W₁ : Fragment α} {W₂ : Fragment β} + {F : EdgeSubset (W₁.disjUnion W₂)} + +private 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) + +private 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) + +private 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) + +private 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 -/ + +private 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⟩ + +private 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 + +private 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 + +private 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⟩ + +private 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 -/ + +private 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⟩ + +private 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 + +private 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 + +private 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⟩ + +private 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 -/ + +private 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) + +private 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 -/ + +private 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))⟩ + +private 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))⟩ + +private 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 + +private 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 + +private 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] + +private 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 -/ + +private 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 + letI := (W₁.disjUnion W₂).flagOrder + letI := W₁.flagOrder + letI := 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⟩) + +private 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 + letI := (W₁.disjUnion W₂).flagOrder + letI := W₂.flagOrder + letI := 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⟩) + +private 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) + +private 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`) -/ + +private 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₂) + +private 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 -/ + +private 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 + +private 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 + +private 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 + +private 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 + +private 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 + +private 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 + +private 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₂) + +private 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 -/ + +private theorem joinEvenEquiv_apply {k : ℕ} + (ψ₁ : (leftSub F).EvenColouring k) + (ψ₂ : (rightSub F).EvenColouring k) : + joinEvenEquiv F k (ψ₁, ψ₂) = joinEven ψ₁ ψ₂ := rfl + +private theorem joinCoreEquiv_apply {ℓ : ℕ} + (φ₁ : (leftSub F).CoreOddColouring ℓ) + (φ₂ : (rightSub F).CoreOddColouring ℓ) : + joinCoreEquiv F ℓ (φ₁, φ₂) = joinCore φ₁ φ₂ := rfl + +private 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 + +/-- **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 [if_pos ((genEvenBoundaryMatch_join hbnd hbnd₁ hbnd₂ + ψ₁ ψ₂).mpr ⟨hP₁, hP₂⟩), if_pos hP₁, if_pos 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 [if_pos ((coreOddBoundaryMatch_join φ₁ φ₂).mpr + ⟨hQ₁, hQ₂⟩), if_pos hQ₁, if_pos 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 [if_neg (fun hu => hQ₂ + ((coreOddBoundaryMatch_join φ₁ φ₂).mp hu).2), + if_neg hQ₂, mul_zero] + · rw [if_neg (fun hu => hQ₁ + ((coreOddBoundaryMatch_join φ₁ φ₂).mp hu).1), + if_neg hQ₁, zero_mul] + · rw [if_neg (fun hu => hP₂ + ((genEvenBoundaryMatch_join hbnd hbnd₁ hbnd₂ + ψ₁ ψ₂).mp hu).2), + if_neg hP₂, mul_zero] + · rw [if_neg (fun hu => hP₁ + ((genEvenBoundaryMatch_join hbnd hbnd₁ hbnd₂ + ψ₁ ψ₂).mp hu).1), + if_neg 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..15be75f25c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.B + +/-! +# The disjoint union: canonical migration + +Migrating canonical data between a union and its components. +-/ + +namespace RS + +open scoped Classical + +/-! ## 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 -/ + +/-- 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⟩ + +/-- 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 -/ + +-- The proof introduces the lexicographic order on the sum, which +-- needs both component orders even though the statement does not. +/-- A left boundary flag's chain stays left, so the product +system's path matching is the left component's. -/ +theorem pathMatch_prodRel_inl + [LinearOrder α] [LinearOrder β] {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 + letI := sumLexLinearOrder α β + 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] + +-- The proof introduces the lexicographic order on the sum, which +-- needs both component orders even though the statement does not. +/-- And likewise on the right. -/ +theorem pathMatch_prodRel_inr + [LinearOrder α] [LinearOrder β] {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 + letI := sumLexLinearOrder α β + 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..0f383ba6dd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean @@ -0,0 +1,1038 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.TheoremQuant +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceOrderIso +import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor +import LeanPool.RegtsSevenster.RS.StatementConverse +import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut +import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedCutDispatch +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. +-/ + +namespace RS + +open scoped Classical + +/-! ## 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 := + Finset.mem_filter + +section SumToolbox + +variable {α β : Type} {W₁ : Fragment α} {W₂ : Fragment β} + +/-! ## Attachment over the union (mirrors `DisjSubsetSplit`) -/ + +/-- 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⟩ + +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} + +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 -/ + +/-- The left component of a union system's match on a left flag, +chosen arbitrarily off the internal flags. -/ +noncomputable def leftDescend (κ : F.RelTransitionSystem) + (g : W₁.Flag) : W₁.Flag := + Sum.elim id (fun _ => g) (κ.match_ (Sum.inl g)) + +/-- The right component of a union system's match on a right flag, +chosen arbitrarily off the internal flags. -/ +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 + +/-! ### Circuit count additivity -/ + +/-- 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 + +end ProdSystems +/-! ## The through-product factorization -/ + +section ThroughSplit + +open EdgeSubset + +variable {α β : Type} + +end ThroughSplit +/-! ## Componentwise colourings -/ + +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 + letI := (W₁.disjUnion W₂).flagOrder + letI := W₁.flagOrder + letI := 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 + letI := (W₁.disjUnion W₂).flagOrder + letI := W₂.flagOrder + letI := 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 + +end ColourSplit +/-! ## 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₂)} + [LinearOrder (α ⊕ β)] {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 ?_ + show ((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₂)} + [LinearOrder (α ⊕ β)] {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 ?_ + show ((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..00a3a7fae6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeColouring.lean @@ -0,0 +1,432 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexSum +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Classical + +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 [dif_pos hc, dif_pos (F.pairing_mem_coreFlags hc)] + exact φ'.prop ⟨f.val, hc⟩ + · rw [dif_neg hc, dif_neg (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 => ?_) + show extendFun hbnd φ' ⟨f.val, coreFlags_subset F f.prop⟩ + = φ'.val f + unfold extendFun + rw [dif_pos 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 + show extendFun hbnd φ' ⟨W.boundaryFlag i, hmem⟩ = c + unfold extendFun + by_cases hc : W.boundaryFlag i ∈ F.coreFlags + · rw [dif_pos hc] + exact hφ' i c hci hc + · rw [dif_neg 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..b111c7708b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.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 +-/ + +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Classical + +variable {α : Type} + +/-- **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 [if_pos hev, if_pos hev] + exact sum_edgeOddColouring hbnd hag + (fun φ' => ∏ v : W.Vertex, + ((F.coreOddSignAt o φ' v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.coreOddListAt o φ' v))) + · rw [if_neg hev, if_neg 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 [if_pos hev] + exact Finset.sum_eq_zero (fun φ _ => if_neg (fun hφ => + hag (throughAgree_of_edgeOddBoundaryMatch hbnd hφ))) + · rw [if_neg 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..8c4f814aff --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean @@ -0,0 +1,1323 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourGlue +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Classical + +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 [dif_neg 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 [dif_pos hc, dif_neg hbnd] + · rw [dif_neg 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 [dif_pos hc] + by_cases hbnd : genBoundarySubsetMatches V s st + · rw [dif_pos hbnd, dif_neg hE] + · rw [dif_neg 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 [dif_pos hc] + by_cases hbnd : genBoundarySubsetMatches V s st + · rw [dif_pos hbnd] + by_cases hE : (EdgeSubset.mk s hc).Eulerian + · rw [dif_pos hE, dif_neg hne] + · rw [dif_neg hE] + · rw [dif_neg 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 [dif_pos hc, dif_pos hbnd, dif_pos hE, dif_pos 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 + 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..6837a094d4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/Eulerian.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 +-/ + +import LeanPool.RegtsSevenster.RS.Common.PermCongr +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. +-/ + +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 + letI := Classical.decEq (W₂.Vertex ⊕ α) + letI := 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] + show 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 + show 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..47dead375a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ExactPairingInstance.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedInstance +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. +-/ + +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 + show 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 + show 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 + show 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..bbf0aaeecb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FibreValue.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords +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. +-/ + +namespace RS + +open scoped Classical + +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, dif_pos 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..f4753d7552 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlagGraph.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 +-/ + +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. +-/ + +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 := + dif_pos 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 := + dif_neg hopen + +/-! ### Sanity checks -/ + +/-- Closing the strand onto itself yields one free circle. -/ +example : + (strand.gluePair 0 1 (by decide)).circles = 1 := by + rw [gluePair, dif_pos (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..5ade2a6ff1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignForm.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 +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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, if_pos 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, if_neg 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 + +/-- **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, if_pos rfl, if_neg 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, if_neg h1, if_pos 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, if_neg h1, if_neg 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 [if_pos (Finset.mem_insert_self p.1 _), + if_pos (Finset.mem_insert_of_mem (Finset.mem_insert_self p.2 _))] + ring + +/-- **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..c76e55c1fa --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.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 +-/ + +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`. +-/ + +namespace RS + +open scoped Classical + +variable {α : Type} {ℓ : ℕ} + +/-- 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..9dda4b5ec2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.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 +-/ + +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. +-/ + +/- the closing `simp` argument list is shared by all 64 order +branches, and each branch uses a different subset of it -/ + +namespace RS + +open scoped Classical + +variable {α : Type} + +/-- **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] + +/-- **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..85490a9e8a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean @@ -0,0 +1,383 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show 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 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 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 [_root_.Equiv.trans_apply] + rw [e₂.attach_comm, e₁.attach_comm] + rcases W₁.attach f with v | ℓ <;> simp + pairing_comm := fun f => by + simp [_root_.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 => + show Sum.inl (e₁.flagEquiv (W₁.pairing g)) = + Sum.inl (W₂.pairing (e₁.flagEquiv g)) + rw [e₁.pairing_comm] + | inr g => + show Sum.inr (e₂.flagEquiv (V₁.pairing g)) = + Sum.inr (V₂.pairing (e₂.flagEquiv g)) + rw [e₂.pairing_comm] + circles_eq := by + show 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 at h1 + rw [e.boundaryFlag_comm i] at h1 + exact h1 + · have h1 := congrArg e.flagEquiv h + simp 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 => e.survivingFlagEquiv_glueAttach i j f + pairing_comm := fun f => by + apply Subtype.ext + show e.flagEquiv (W₁.pairing f.val) = W₂.pairing (e.flagEquiv f.val) + exact e.pairing_comm f.val + circles_eq := by + show 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 [dif_pos 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 [dif_neg hfi, dif_pos 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 [dif_neg hfi, dif_neg 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] + show 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] + show 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 + show 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 => e.survivingFlagEquiv_glueAttach i j f + pairing_comm := fun f => + 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 [dif_pos ((e.gluePair_case_preserved i j).mp h₁)] + exact e.gluePairClosedCongr h₁ + ((e.gluePair_case_preserved i j).mp h₁) + · rename_i h₁ + rw [dif_neg (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 := 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 := 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..4358ceac05 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GenBoundaryStates.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 +-/ + +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 ℕ. +-/ + +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..bf7008a7bd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueAmbient.lean @@ -0,0 +1,533 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv +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. +-/ + +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 + +/-- 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. -/ +private noncomputable def gluePairClosed_disjUnion (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 f := 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 + show (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 + show (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 + show (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 + show (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 + pairing_comm f := by + rcases f with ⟨g, hg⟩ | g + · apply Subtype.ext + show Sum.inl (W.pairing g) = (W.disjUnion V).pairing (Sum.inl g) + rfl + · apply Subtype.ext + show Sum.inr (V.pairing g) = (W.disjUnion V).pairing (Sum.inr g) + rfl + circles_eq := by + show (W.circles + 1) + V.circles = (W.circles + V.circles) + 1 + omega + +/-- The open case of glue-in-ambient: when the two boundary flags +bound distinct edges in W, the LHS and RHS produce equivalent +fragments. -/ +private noncomputable def gluePairOpen_disjUnion (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 f := 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 + show (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 + show (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 + show (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 + show (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 + pairing_comm 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 [dif_pos (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 [dif_neg (show (W.disjUnion V).pairing (Sum.inl g) ≠ + (W.disjUnion V).boundaryFlag (Sum.inl i) from + fun h => hfi (Sum.inl.inj h)), + dif_pos (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 [dif_neg (show (W.disjUnion V).pairing (Sum.inl g) ≠ + (W.disjUnion V).boundaryFlag (Sum.inl i) from + fun h => hfi (Sum.inl.inj h)), + dif_neg (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 [dif_neg (show (W.disjUnion V).pairing (Sum.inr g) ≠ + (W.disjUnion V).boundaryFlag (Sum.inl i) from + Sum.inr_ne_inl), + dif_neg (show (W.disjUnion V).pairing (Sum.inr g) ≠ + (W.disjUnion V).boundaryFlag (Sum.inl j) from + Sum.inr_ne_inl)] + rfl + circles_eq := by + show 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 [dif_pos hunion] + exact gluePairClosed_disjUnion 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 [dif_neg hunion] + exact gluePairOpen_disjUnion 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 + show (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 + show (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 (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⟩ + · show (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⟩ + · show (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)) + · show 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 [dif_pos hfi, + dif_neg (show ¬ W.pairing ((flagE.symm f).val) = + W.boundaryFlag j from hfj), + dif_pos (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 [dif_neg hfi, dif_pos hfj, + dif_pos (show W.pairing ((flagE.symm f).val) = + W.boundaryFlag j from hfj)] + exact Subtype.ext rfl + · rw [dif_neg hfi, dif_neg hfj, + dif_neg (show ¬ W.pairing ((flagE.symm f).val) = + W.boundaryFlag j from hfj), + dif_neg (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 + · show ((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 + · show ((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 + show 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..ddf5f2859b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean @@ -0,0 +1,685 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.CutMatching +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Equiv Classical + +/-! ## 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 [if_pos 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 [if_neg h1, if_pos 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 [if_neg h1, if_neg 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 + show (chordInv (Fg) + (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + ⟨y.val.val, _⟩).val = _ + rw [hkey] + show _ = ((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 [if_pos h1, if_pos (Subtype.ext h1 : + (cutMatching (Fl) κ o).edge y.val = ⟨i, hbi⟩)] + rfl + · by_cases h2 : chordInv (Fl) κ y.val.val = j + · rw [if_neg h1, if_pos h2, + if_neg (fun hx => h1 (congrArg Subtype.val hx)), + if_pos (Subtype.ext h2 : + (cutMatching (Fl) κ o).edge y.val = ⟨j, hbj⟩)] + rfl + · rw [if_neg h1, if_neg h2, + if_neg (fun hx => h1 (congrArg Subtype.val hx)), + if_neg (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, if_pos (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, if_neg (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 + show (rewire hopen f).val ∈ s + rw [show (rewire hopen f).val = W.pairing (W.boundaryFlag j) + from by unfold rewire; rw [dif_pos 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 + show (rewire hopen f).val ∈ s + rw [show (rewire hopen f).val = W.pairing (W.boundaryFlag i) + from by unfold rewire; rw [dif_neg h1, dif_pos 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 [dif_neg h1, dif_neg 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 + 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..1509eb3759 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChords.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 +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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, dif_pos 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 [if_neg 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..2bbb817bdf --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean @@ -0,0 +1,1339 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +/-! ### 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} + +/-- 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] + +/-- 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 : ℕ} (_ : 1 ≤ n) + (hcont : ∀ t, t < n → + W.pairing (iterWalk κ f t) ∈ F.internalFlags) + (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 hcont] + 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 strictly inside 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 : ℕ} (hm1 : 1 ≤ m) (hmk : m ≤ k) : + ¬ κ.PeriodicFlag (iterWalk κ b m) := by + apply not_periodic_of_boundary_chain κ _ + (iterWalk_mem_internal κ k hm1 hmk hcont) + 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) + show (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 + show (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 + show (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⟩ + show κ'.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 : 1 ≤ t + 1) + (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 κ' 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) 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)⟩ + +/-- **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 + -- ═══════ SETUP: THE TWO SPLICED CYCLES ═══════ + -- The open glue rewires the two interface flags; the walk out of + -- `bf_i` and the reversed walk out of `bf_j` splice into the two + -- cycles `SA`, `SB`, whose basic properties are collected here. + -- interface rewires + 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_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_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_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 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 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 + 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 + have hinj : 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 + 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 + 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 ?_⟩ + show 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 ?_⟩ + show 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 : ∀ 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 + 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 ?_) + show (κ'.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 ?_ + show 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 ?_ + show 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] + 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 + +/-- **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 [if_pos 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 [if_neg 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..986db638a1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueComm.lean @@ -0,0 +1,2169 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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`. -/ +private 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 [DecidableEq α] + (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 [DecidableEq α] + (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. -/ +private def closedClosed_equiv [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⟩ + (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⟩ + (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 [dif_neg hfi, dif_neg 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 [dif_pos 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 [dif_neg hfi, dif_pos hfj] + +-- The kl glue is open in the ij-first fragment. +private theorem openOpen_second_open_ij [DecidableEq α] + (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 + show (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 [DecidableEq α] + (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 + show (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) + +/-- 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. -/ +private def openOpen_disjoint_equiv [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)) + (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)) + (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 f := by + exact doubleGlueAttach_comm W hik hil hjk hjl f + pairing_comm f := by + -- 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 + show (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⟩ + · -- ═══════ PARTNER IS bF i ═══════ + -- 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] + · -- ═══════ 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] + 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 [DecidableEq α] + (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 [DecidableEq α] + (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`. -/ +private def closedOpen_equiv [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)) + (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⟩ + (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. + show (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 [DecidableEq α] + (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 [DecidableEq α] + (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`. -/ +private def openClosed_equiv [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⟩ + (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)) + (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. + show (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 [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) + (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 [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_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) + +/-- Configuration (2), variant {ik}: one cross-edge `W.pairing(bFi) = bFk`. +Both glues are open in both orders; circles = `W.circles`. -/ +private def oneCross_ik_equiv [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)) + (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)) + (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 f := by + exact doubleGlueAttach_comm W hik hil hjk hjl f + pairing_comm f := by + 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 + show (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] + 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 [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).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 [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 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`. -/ +private def oneCross_il_equiv [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)) + (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)) + (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 + show (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 [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) + (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 [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_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`. -/ +private def oneCross_jk_equiv [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)) + (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)) + (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 + show (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 [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).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 [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 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) + +/-- Configuration (2), variant {jl}: one cross-edge `W.pairing(bFj) = bFl`. +Both glues are open in both orders; circles = `W.circles`. -/ +private def oneCross_jl_equiv [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)) + (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)) + (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 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 + show (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] + 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 [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) + (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 [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_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`. -/ +private def twoCross_ikjl_equiv [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⟩ + (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⟩ + (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 + show (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 [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) + (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 [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_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`. -/ +private def twoCross_iljk_equiv [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⟩ + (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⟩ + (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 + show (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 _ (closedClosed_second_ij W hik hil hjk hjl h_ij + h_kl)] + rw [gluePair_eq_closed _ (closedClosed_second_kl W hik hil hjk hjl h_ij + h_kl)] + exact closedClosed_equiv 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 _ (closedOpen_second_open W hik hil hjk hjl h_ij + h_kl)] + rw [gluePair_eq_closed _ (closedOpen_second_closed W hkl hik hil hjk hjl + h_ij h_kl)] + exact closedOpen_equiv 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 _ (openClosed_second_closed W hij hik hil hjk hjl + h_ij h_kl)] + rw [gluePair_eq_open _ (openClosed_second_open W hik hil hjk hjl h_ij + h_kl)] + exact openClosed_equiv 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 _ (twoCross_ikjl_second_closed_kl W hij hkl hik + hil hjk hjl + h_ij hcross_ik hcross_jl)] + rw [gluePair_eq_closed _ (twoCross_ikjl_second_closed_ij W hij hkl hik + hil hjk hjl + h_kl hcross_ik hcross_jl)] + exact twoCross_ikjl_equiv W hij hkl hik hil hjk hjl h_ij h_kl + hcross_ik hcross_jl + · -- Config (2) variant {ik} + rw [gluePair_eq_open _ (oneCross_ik_second_open_kl W hij hkl hik hil + hjk hjl + h_ij hcross_ik hcross_jl)] + rw [gluePair_eq_open _ (oneCross_ik_second_open_ij W hij hkl hik hil + hjk hjl + h_kl hcross_ik hcross_jl)] + exact oneCross_ik_equiv 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 _ (twoCross_iljk_second_closed_kl W hij hkl + hik hil hjk hjl + h_ij hcross_il hcross_jk)] + rw [gluePair_eq_closed _ (twoCross_iljk_second_closed_ij W hij hkl + hik hil hjk hjl + h_kl hcross_il hcross_jk)] + exact twoCross_iljk_equiv W hij hkl hik hil hjk hjl h_ij h_kl + hcross_il hcross_jk + · -- Config (2) variant {il} + rw [gluePair_eq_open _ (oneCross_il_second_open_kl W hij hkl hik hil + hjk hjl + h_ij h_kl hcross_il hcross_jk)] + rw [gluePair_eq_open _ (oneCross_il_second_open_ij W hij hkl hik hil + hjk hjl + h_ij h_kl hcross_il hcross_jk)] + exact oneCross_il_equiv 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 _ (oneCross_jk_second_open_kl W hij hkl hik hil + hjk hjl + h_ij hcross_jk hcross_il)] + rw [gluePair_eq_open _ (oneCross_jk_second_open_ij W hij hkl hik hil + hjk hjl + h_kl hcross_jk hcross_il)] + exact oneCross_jk_equiv 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 _ (oneCross_jl_second_open_kl W hij hkl hik + hil hjk hjl + h_ij h_kl hcross_jl hcross_ik)] + rw [gluePair_eq_open _ (oneCross_jl_second_open_ij W hij hkl hik + hil hjk hjl + h_ij h_kl hcross_jl hcross_ik)] + exact oneCross_jl_equiv 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 _ (openOpen_second_open_ij W hij hik hil hjk + hjl + h_ij h_kl hcross_ik hcross_jk)] + rw [gluePair_eq_open _ (openOpen_second_open_kl W hkl hik hil hjk + hjl + h_ij h_kl hcross_ik hcross_il)] + exact openOpen_disjoint_equiv 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..af4e792aa3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCrossDelta.lean @@ -0,0 +1,378 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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 := + if_neg (fun h => lt_irrefl _ h.1) + +/-- 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 if_neg (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 if_neg (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 + +/-- 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] + +/-- 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] + +/-- 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 [if_pos hI, if_pos hJ, if_neg (fun hc => + ((hxor.mp hc).elim (fun h => h.2 hJ) (fun h => h.2 hI)))] + · rw [if_pos hI, if_neg hJ, + if_pos (hxor.mpr (Or.inl ⟨hI, hJ⟩))] + · rw [if_neg hI, if_pos hJ, + if_pos (hxor.mpr (Or.inr ⟨hJ, hI⟩))] + · rw [if_neg hI, if_neg hJ, if_neg (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 -/ + +/-- **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..e50c108019 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueFold.lean @@ -0,0 +1,2310 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Common.PairDisjoint +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. +-/ + +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 -/ + +private 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 + show 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 -/ + +private noncomputable def glueListCongr_aux + (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 => + show ((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) := + glueListCongr_aux 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 + show 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) + show 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) + show 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 + show W.pairing f.val = W.boundaryFlag i; rw [← hbi]; exact hfi + rw [dif_pos hfi'] + exact Subtype.ext (congrArg W.pairing hbj) + · rename_i hfi + have hfi' : ¬(W.pairing (flagE f).val = W.boundaryFlag i) := by + show ¬(W.pairing f.val = W.boundaryFlag i); rw [← hbi]; exact hfi + rw [dif_neg hfi'] + split + · rename_i hfj + have hfj' : W.pairing (flagE f).val = W.boundaryFlag j := by + show W.pairing f.val = W.boundaryFlag j; rw [← hbj]; exact hfj + rw [dif_pos hfj'] + exact Subtype.ext (congrArg W.pairing hbi) + · rename_i hfj + have hfj' : ¬(W.pairing (flagE f).val = W.boundaryFlag j) := by + show ¬(W.pairing f.val = W.boundaryFlag j); rw [← hbj]; exact hfj + rw [dif_neg 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 + show 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 ═══════ + | [], _, _ => + show 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)) := + (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 ⟨?_⟩ + show ((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)) := + (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 + · show ((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 + · show ((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 + · show ((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 + · show ((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_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 => + 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 + show 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 ⟨?_⟩ + show ((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) + +/-- 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) := + (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 + show 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 ═══════ + | [], _, _ => + show 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 ⟨?_⟩ + show (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) := + (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 [DecidableEq α] + {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 + 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') + letI := 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) := + (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..adf3c83d8b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueLedger.lean @@ -0,0 +1,658 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Equiv Classical + +/-! ## 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 [dif_neg hb, dif_neg 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..12f33d89ec --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GluePathMatch.lean @@ -0,0 +1,857 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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 ⟨?_, ?_⟩ + · show ((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]) + · show (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) + +/-- 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⟩ + +/-- 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} [LinearOrder α'] + {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₂)) + +/-- **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] + +/-- **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 : ∀ 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 + have hinvol : ∀ (x : W.Flag) + (hx : x ∈ (EdgeSubset.mk + (liftSubsetOpen hopen s') hc : + EdgeSubset W).boundaryFlags) + (he : κ.pathMatch b'.val hbl = x), + κ.pathMatch x hx = b'.val := by + intro x hx he + subst he + exact κ.pathMatch_invol hbl + + 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 h1 : ∀ (x : W.Flag) (hx : x ∈ (EdgeSubset.mk + (liftSubsetOpen hopen s') hc : + EdgeSubset W).boundaryFlags) + (he : κ.pathMatch (W.boundaryFlag j) hbfj = x), + κ.pathMatch x hx = W.boundaryFlag j := by + intro x hx he + subst he + exact κ.pathMatch_invol hbfj + have h2 := h1 (W.boundaryFlag i) hbfi hcon + have h3 := hinvol (W.boundaryFlag i) 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 + show ((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 + show (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 : ∀ m, iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc + κ) + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + + 1)) m = + iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + 1 + + m) := by + intro m + induction m with + | zero => rfl + | succ m ih => + show (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ + ((W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + b' (k + 1)) m)) = + (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 + 1 + m))) + rw [ih] + 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] + +/-- **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 : ∀ 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 + have hinvol : ∀ (x : W.Flag) + (hx : x ∈ (EdgeSubset.mk + (liftSubsetOpen hopen s') hc : + EdgeSubset W).boundaryFlags) + (he : κ.pathMatch b'.val hbl = x), + κ.pathMatch x hx = b'.val := by + intro x hx he + subst he + exact κ.pathMatch_invol hbl + + 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 h1 : ∀ (x : W.Flag) (hx : x ∈ (EdgeSubset.mk + (liftSubsetOpen hopen s') hc : + EdgeSubset W).boundaryFlags) + (he : κ.pathMatch (W.boundaryFlag i) hbfi = x), + κ.pathMatch x hx = W.boundaryFlag i := by + intro x hx he + subst he + exact κ.pathMatch_invol hbfi + have h2 := h1 (W.boundaryFlag j) hbfj hcon + have h3 := hinvol (W.boundaryFlag j) 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 + show ((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 + show (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 : ∀ m, iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc + κ) + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + + 1)) m = + iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + 1 + + m) := by + intro m + induction m with + | zero => rfl + | succ m ih => + show (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ + ((W.gluePairOpen i j hij hopen).pairing + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) + b' (k + 1)) m)) = + (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 + 1 + m))) + rw [ih] + 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 +/-- Participation transports through the open glue at label +level. -/ +theorem glued_participation_iff + {α : 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') + (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..512679370d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueRelTransport.lean @@ -0,0 +1,1249 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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 [dif_neg h1, dif_neg 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 [dif_pos 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 [dif_neg hne, dif_pos 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 [dif_pos 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 [dif_pos 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 [dif_pos 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 [dif_pos 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 [dif_pos 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 ⟨?_, ?_⟩ + · show (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) + show (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 + show (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 + show (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 ⟨?_, ?_⟩ + · show (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 + show (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 + show (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 + show (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..288681edc0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplit.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 +-/ + +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`. +-/ + +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..effb2e2097 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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..73bf3c4a42 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/A.lean @@ -0,0 +1,465 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +/-! ## 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 dif_pos 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 [dif_neg (Ne.symm hij), dif_pos 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 [dif_neg a.prop.1, dif_neg 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 + +/-- 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 + show ((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 + show ((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..7a5169c0d4 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/C.lean @@ -0,0 +1,683 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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 + show ((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 + show ((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 [dif_neg hp1, dif_neg hp2, dif_pos 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 [dif_neg hp1, dif_neg hp2, dif_neg hfi, dif_pos 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 [dif_pos hpi', dif_neg hfi, dif_neg 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 [dif_neg hpi', dif_pos hpj', dif_neg hfi, + dif_neg hfj] + exact congrArg ψ'.val (Subtype.ext hfeq).symm + · rw [dif_neg hpi', dif_neg hpj', dif_neg hfi, + dif_neg 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 + show (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 [dif_neg g.prop.1, dif_neg 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⟩ := dif_pos 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 + show (if hfi : W.boundaryFlag j = W.boundaryFlag i then _ + else if hfj : W.boundaryFlag j = W.boundaryFlag j then _ + else _) = _ + rw [dif_neg (fun hEq => + hij (W.boundaryFlag_injective hEq).symm), dif_pos 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 ?_))) + show (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 ?_))) + show (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 => ?_) + show (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 [dif_pos 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 [dif_neg hfi, dif_pos 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 [dif_neg hfi, dif_neg hfj] + +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 [if_neg (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..c1472635a1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSubsetBij.lean @@ -0,0 +1,567 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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). +-/ + +namespace RS + +open scoped Classical + +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 [if_pos 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 [if_pos 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 [if_pos 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 [if_pos 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 [if_pos 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 [if_pos 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 + letI := Classical.decEq (W.Vertex ⊕ α) + letI := 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 + letI := Classical.decEq (W.Vertex ⊕ α) + letI := 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..6e4a3c819c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GramRank.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 +-/ + +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. +-/ + +namespace RS + +open Classical + +/-- **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..5072f0cd0b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomCompose.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 +-/ + +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. +-/ + +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 ?_ + show (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 + show 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 + show 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 + show 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 + show 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..0b61afb5b3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomSpaces.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 +-/ + +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. +-/ + +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..065781f680 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTensor.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 +-/ + +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. +-/ + +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 ?_ + show (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 + show 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 + show 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 + show 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 + show 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..fe29eb44b0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceCyclic.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 +-/ + +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. +-/ + +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 + show 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..e9d43d9af0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceNondegenerate.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCategory +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). +-/ + +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 + show (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..a835714797 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean @@ -0,0 +1,1070 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 [dif_pos 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 [dif_neg h₁] + by_cases h₂ : ℓ.val < t + · -- ═══════ CASE: not-yet-glued interface label ═══════ + rw [dif_pos 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 [dif_neg 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 [dif_pos 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 [dif_neg 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] + show 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 + show ((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 + show ((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 [dif_pos hlt] + · have hk_eq : k = t' := by omega + simp only [dif_neg 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 [dif_neg hg] + right_inv y := by + match y with + | Sum.inl (⟨k, hk⟩, b) => + dsimp only + simp only [dif_pos hk] + | Sum.inr g => + dsimp only + by_cases hg : g = F.boundaryFlag ⟨t', by omega⟩ + · simp only [dif_pos hg, dif_neg (show ¬ (t' : ℕ) < t' from Nat.lt_irrefl + t')] + exact congrArg Sum.inr hg.symm + · simp only [dif_neg 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 [Fin.lt_def, Fin.castSucc]; 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 + rw [Equiv.apply_eq_iff_eq_symm_apply] + 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 + rw [Equiv.apply_eq_iff_eq_symm_apply] + 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.apply_eq_iff_eq_symm_apply _).mpr key.symm + +/-! ### The stage step equivalence -/ + +private 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) + +private abbrev targetFragment (t t' u : ℕ) (ht' : t' ≤ t) + (F : Fragment (Fin (t + u))) := + ((strandBundle t').disjUnion F).relabel (stageEquiv t t' u ht') + +private 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) (stageStep_hopen t t' u ht F)).relabel (interfaceStepEquiv t t' u) + +-- Raised budget: the four equivalence fields are checked against +-- the glued fragment at once, each on both label halves. +/-- 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. -/ +private 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 + · -- ═══════ CASE: strand flag (⟨k, hk⟩, b) ═══════ + 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, dif_pos 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⟩, dif_pos hlt] + · simp only [ite_true] + rw [stageEquiv_inl t t' u (by omega) ⟨t' + k, by omega⟩, + dif_neg (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⟩, + dif_pos (show (k : ℕ) < t' + 1 from by omega)] + · simp only [ite_true] + rw [stageEquiv_inl t (t' + 1) u ht ⟨(t' + 1) + k, by omega⟩, + dif_neg (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, dif_neg 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⟩, + dif_neg (show ¬ (t' : ℕ) < t' from Nat.lt_irrefl t'), + dif_pos (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⟩, + dif_pos (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 + · -- ═══════ CASE 3: F-flag g ═══════ + 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) ℓ, dif_pos 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 ℓ, + dif_pos (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) ℓ, + dif_neg (show ¬ ℓ.val < t' from hℓ_lt_t'), dif_pos 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 ℓ, + dif_neg (show ¬ ℓ.val < t' + 1 from by omega), dif_pos + 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) ℓ, + dif_neg (show ¬ ℓ.val < t' from hℓ_lt_t'), dif_neg 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 ℓ, + dif_neg (show ¬ ℓ.val < t' + 1 from by omega), dif_neg + 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 + pairing_comm := fun f => by + obtain ⟨fval, hne⟩ := f + show (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 [dif_neg hni, dif_neg 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, dif_pos 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, dif_pos 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, dif_pos 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, dif_neg 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 [dif_neg hni, dif_pos hnj] + show (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, dif_neg (Nat.lt_irrefl t')] + rw [hflag_rw, hflag_f] + show 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 [dif_neg hni, dif_neg 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 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 + show 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`. -/ +private 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) (stageStep_hopen t t' u ht F) := by + unfold Fragment.gluePair + exact dif_neg (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. -/ +private noncomputable def glueInterface_strandBundle_desc + (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 := glueInterface_strandBundle_desc 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 + (glueInterface_strandBundle_desc 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..5a8a7ac33c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLawRight.lean @@ -0,0 +1,844 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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)`. +-/ + +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 [dif_pos h] + · simp only + [dif_neg h, dif_neg (show ¬ (t' + (ℓ.val - s) < t' + t') from by omega)] + exact congrArg Sum.inl (Fin.ext (by simp; omega)) + · -- Sum.inr a + simp only + rw [dif_pos a.isLt] + right_inv y := by + rcases y with j | k + · -- Sum.inl j + simp only + rw [dif_pos j.isLt] + · -- Sum.inr k + simp only + by_cases h : k.val < t' + t' + · rw [dif_pos h] + · simp only + [dif_neg h, dif_neg (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 [dif_pos (show ℓ.val < s + 0 from by omega), dif_pos h] + · rw [dif_neg (show ¬ ℓ.val < s + 0 from by omega), dif_neg 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) + show 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] + show 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 + show (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 [dif_pos (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 + show (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 [dif_neg hg] + · -- f = Sum.inr (⟨k, hk⟩, b) + by_cases hlt : k < t' + · simp only [dif_pos 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 [dif_neg hlt, + show F.boundaryFlag ⟨s + t', by omega⟩ = F.boundaryFlag + ⟨s + t', by omega⟩ from rfl, + 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 [dif_pos hg, dif_neg (show ¬ (t' : ℕ) < t' from Nat.lt_irrefl + t')] + exact congrArg Sum.inl hg.symm + · simp only [dif_neg hg] + | Sum.inr (⟨k, hk⟩, b) => + simp only [dif_pos hk] + +/-! ### The stage step equivalence -/ + +private 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) + +private abbrev targetFragmentR (s t' u : ℕ) (ht' : t' ≤ u) + (F : Fragment (Fin (s + u))) := + (F.disjUnion (strandBundle t')).relabel (stageEquivR s t' u ht') + +private 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) (stageStepR_hopen s t' u ht F)).relabel (interfaceStepEquiv s t' + u) + +-- Raised budget: as for the left-hand step. +/-- 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. -/ +private 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⟩ + · -- ═══════ CASE: F-flag g ═══════ + 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, dif_pos 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, + dif_pos (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, dif_neg (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, + dif_neg (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 + · -- ═══════ CASE: strand flag (⟨k, hk⟩, b) ═══════ + 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, dif_pos 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, dif_neg 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, + dif_neg (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 + pairing_comm f := by + obtain ⟨fval, hne⟩ := f + show (stageStepFlagEquivR s t' u ht F) + (Fragment.rewire (stageStepR_hopen s t' u ht F) ⟨fval, hne⟩) = + (targetFragmentR s t' u (by omega) F).pairing + ((stageStepFlagEquivR s t' u ht F) ⟨fval, hne⟩) + rcases fval with g | ⟨⟨k, hk⟩, b⟩ + · -- ═══════ CASE: F-flag g ═══════ + 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, dif_pos hpi] + show (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, dif_neg (Nat.lt_irrefl t')] + rw [hflag_rw, hflag_f] + show 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 [dif_neg hni, dif_neg 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 + · -- ═══════ CASE: strand flag (⟨k, hk⟩, b) ═══════ + 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 [dif_neg hni, dif_neg 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, dif_pos 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, dif_pos 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, dif_neg hni, dif_pos hpair_eq_bdy] + show (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, dif_neg hlt] + rw [hflag_rw, hflag_f] + rfl + +/-! ### 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, dif_pos ℓ.isLt] + · rw [stageEquivR_inr] + +/-- In the base fragment, the glue is always open, so `gluePair` +coincides with `gluePairOpen`. -/ +private 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) (stageStepR_hopen s t' u ht F) := by + unfold Fragment.gluePair + exact dif_neg (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. -/ +private noncomputable def glueInterface_strandBundle_desc_right + (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 := glueInterface_strandBundle_desc_right 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 + (glueInterface_strandBundle_desc_right 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..3b36da3d06 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceAlternate.lean @@ -0,0 +1,1149 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Classical + +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 + show 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 + show 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 + show 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 + show 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 + show 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 [if_pos (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 [dif_neg 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 [dif_pos 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 [dif_neg 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 [dif_neg 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 [dif_pos 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} [LinearOrder L'] + {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..55334d8634 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceContract.lean @@ -0,0 +1,279 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Equiv Classical + +/-- 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 [dif_pos 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..0d3b7f6a35 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceCut.lean @@ -0,0 +1,684 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueLedger +import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexSum +import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperGram +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceOrderIso +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Equiv Classical + +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 + show 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 + show 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 + show 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 [if_pos hw] at h + show ((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 ?_) + show (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 + 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 [dif_pos 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 [dif_pos hc, dif_pos hc] + by_cases hbnd : genBoundarySubsetMatches V s st + · rw [dif_pos hbnd, dif_pos hbnd] + by_cases hE : (EdgeSubset.mk s hc).Eulerian + · rw [if_pos hE, if_pos hE] + by_cases hne : Nonempty (EdgeSubset.mk s hc).CanonData + · rw [dif_pos hne] + exact throughValueC_isEmpty _ h st hbnd hne + · rw [dif_neg hne] + unfold EdgeSubset.throughValueC + rw [dif_neg hne] + · rw [if_neg hE, if_neg hE] + · rw [dif_neg hbnd, dif_neg hbnd] + · rw [dif_neg hc, dif_neg 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] + show (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] + show (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) + show 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) + show 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..432add2f0a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceOrderIso.lean @@ -0,0 +1,272 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +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 + show (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 + show 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..b0589a75be --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceShift.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 +-/ + +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. +-/ + +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) + show 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) + show 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)))) + +-- Raised budget: 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 ?_ + show ((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 ?_ + show 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..418788c0c9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InvolutionCard.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 +-/ + +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. +-/ + +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..b55d11dad7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LabelChords.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 +-/ + +import LeanPool.RegtsSevenster.RS.Common.PairDisjoint +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. +-/ + +namespace RS + +open scoped Classical + +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..4ffa030315 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerCast.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 +-/ + +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Equiv Classical + +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') + [Fintype β] + (κ : 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..6ea58db3bb --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerCast +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Equiv Classical + +/-- 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 [dif_pos 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 [dif_neg 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. +-/ + +-- Raised budget: 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⟩ + +-- Raised budget: 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 + have hzero : ∀ {W : Fragment (Fin (0 + 0) ⊕ Fin (0 + 0))} + (F : EdgeSubset W) (M N : DirMatching (UsedLab F)), + DirMatching.unionCount M N = 0 := by + intro W F M N + haveI : IsEmpty (UsedLab F) := ⟨fun x => isEmptyElim x.val⟩ + exact DirMatching.unionCount_of_isEmpty M N + simp only [glueCount, stageLedger, ledgerOf, glueData, hzero, + 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 [if_pos ⟨hcl, hb⟩, if_pos hb] + · rw [if_neg (fun h => hb h.2), if_neg hb]] + exact stageLedger_stepDataClosed n V D hcl + · rw [stepData_eq_open n V D hcl, stageLedger_stageDataOfEq, + if_neg (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 + +/-- 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 + haveI : IsEmpty (UsedLab F) := ⟨fun x => isEmptyElim x.val⟩ + rw [ledgerOf, DirMatching.unionCount_of_isEmpty, Nat.add_zero] + +/-- **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 + show 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 + show (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 [dif_pos hcl, if_pos hcl] + rfl + · rw [dif_neg hcl, if_neg hcl] + show V.circles = V.circles + 0 + omega + show (glueInterface 0 n 0 _).circles = _ + rw [ih, hstep] + show _ = 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..ff2e504409 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean @@ -0,0 +1,306 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet +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`). +-/ + +namespace RS + +open scoped Classical + +section PairSets + +variable {k ℓ : ℕ} {α : Type} + +/-- 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 + 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 + +/-- 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 + 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..4fe38f810a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerStage.lean @@ -0,0 +1,433 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Fragment Equiv Classical + +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 [if_neg (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 [if_pos 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..b78cac40bf --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerValue.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingValue +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. +-/ + +namespace RS + +open scoped Classical + +/-- **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..95f400b37f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopExample.lean @@ -0,0 +1,488 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 <;> simp + 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 + haveI : 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 + letI := 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 + letI := loopGraph.flagOrder + letI := 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 + letI := loopGraph.flagOrder + letI := 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] + show (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 + haveI : 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 => dif_neg (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, + dif_pos loopEmpty_closed, dif_pos loopFull_closed] + show (if loopEmpty.Eulerian then + loopEmpty.mixedValue (charPolyFunctional θ) else 0) + + (if loopFull.Eulerian then + loopFull.mixedValue (charPolyFunctional θ) else 0) = θ - 2 + rw [if_pos eulerian_loopEmpty, if_pos 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..aa0d8386de --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopVerify.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 +-/ + +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. +-/ + +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 [if_pos 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 [if_neg hb] + rw [Fintype.sum_eq_single cPhi hzero] + rw [if_pos 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, + if_pos (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, + if_neg (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, + if_pos (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, + if_neg (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..ecc3fd7bbd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/MixedPartition.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 +-/ + +import LeanPool.RegtsSevenster.RS.Common.ListSign +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. +-/ + +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 [if_pos hnd', if_pos 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 [if_neg (fun hh => hnd (hperm.nodup_iff.mp hh)), if_neg 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 [if_pos hnd', if_pos 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 [if_neg (fun hh => hnd (hperm.nodup_iff.mp hh)), if_neg 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 [dif_pos h, dif_neg (show ¬ c.val + ℓ < ℓ by omega)] + exact Fin.ext (by show c.val + ℓ - ℓ = c.val; omega) + · have hc : c.val < 2 * ℓ := c.isLt + rw [dif_neg h, dif_pos (show c.val - ℓ < ℓ by omega)] + exact Fin.ext (by show 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 + letI := W.flagOrder + letI := 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 + show 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 + show ψ.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 + · show 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 + show φ.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 + show 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 + show 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 + show 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 [dif_pos h, if_pos h, + if_neg (show ¬ i.val + ℓ < ℓ by omega)] + norm_num + · have hi : i.val < 2 * ℓ := i.isLt + rw [dif_neg h, if_neg h, + if_pos (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..aafb462725 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalInstance.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalNat +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. +-/ + +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 + show 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 + show 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 + show 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 + show 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..6f07084a41 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalNat.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleMapClasses +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorAssoc +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorUnit +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. +-/ + +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..df856c7dca --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalStruct.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleMapClasses +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. +-/ + +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 + show 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 + show 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 + show 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 + show 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 + show 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 + show 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 + show 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..e41587add3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/Multiplicativity.lean @@ -0,0 +1,186 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 + show 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 + haveI : 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 + show 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 + show 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..3b378f98d7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/NonSeparatedStep.lean @@ -0,0 +1,1868 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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). +-/ + +namespace RS + +open scoped Classical + +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, + if_pos hseg.hcS, if_neg hseg.haS, hsame] + by_cases h3 : f = c + · subst h3 + rw [RelTransitionSystem.repair_match_c hsq, + if_neg hseg.haS, if_pos hseg.hcS, Bool.not_not, hsame] + by_cases h2 : f = b + · subst h2 + rw [RelTransitionSystem.repair_match_b hsq, + if_neg hseg.hdS, if_pos hseg.hbS, Bool.not_not, + hdflip, hbflip, hsame] + by_cases h4 : f = d + · subst h4 + rw [RelTransitionSystem.repair_match_d hsq, + if_pos hseg.hbS, if_neg hseg.hdS, hbflip, hdflip, hsame] + · rw [RelTransitionSystem.repair_match_of_ne hsq h1 h2 h3 h4] + by_cases hfS : f ∈ S + · rw [if_pos (hseg.match_mem f hfS h2 h3), if_pos hfS, + o.match_flip f hf] + · rw [if_neg (hseg.match_notMem hsq hf hfS h1 h4), if_neg 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 [if_pos (hseg.pairing_mem f hfS), if_pos hfS, + o.pairing_flip f hf hp] + · rw [if_neg (hseg.pairing_notMem hfS), if_neg 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 := if_neg 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 [if_pos (hSpair _ hg), if_pos hg, φ.prop g] + · rw [if_neg (hnot _ hg), if_neg 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 + show (if g.val ∈ S then + oddPartner ℓ ((segFlipColouring hSpair φ).val g) + else (segFlipColouring hSpair φ).val g) = φ.val g + by_cases hg : g.val ∈ S + · rw [if_pos hg, segFlipColouring_val hSpair φ g, if_pos hg, + oddPartner_invol] + · rw [if_neg hg, segFlipColouring_val hSpair φ g, if_neg 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 φ _, if_neg (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, if_pos 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, if_neg 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) + +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) + +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 := + 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 := + 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 := + 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 := + 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 [if_pos hgS] at hgout + refine Or.inr ⟨hgfl, hgat, ?_, hgS⟩ + cases hb : o.isOut g + · rw [hb] at hgout + cases hgout + · rfl + · rw [if_neg 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, if_neg hgS] + exact hgout + · refine ⟨hgfl, hgat, ?_⟩ + rw [hd.hiso g, if_pos 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] + +/-- 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 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] + 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 μ ((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 + _ = (-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] + +/-- 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 φ _ => ?_)) + show (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 + +-- Raised budget: the parametric core carries the segment data, +-- both orientations and the boundary state through one +-- elaboration. +/-- 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 + congr 1 + 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 + haveI : 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..be6cd809b9 --- /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 +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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` and all intermediate pairings are internal. -/ +theorem iterWalk_add_period (κ : F.RelTransitionSystem) + (f : W.Flag) (n k : ℕ) + (hperiod : iterWalk κ f n = f) + (_hcont : ∀ j, j < n → + W.pairing (iterWalk κ f j) ∈ F.internalFlags) : + 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, k < n → + iterWalk κ f (n * (j / n) + k) = iterWalk κ f k := by + intro k _hkn + 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 hcont] + exact ih + rw [show j = n * (j / n) + j % n from + (Nat.div_add_mod j n).symm] + rw [hmod (j % n) (Nat.mod_lt j (by omega))] + 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) + show W.pairing (iterWalk κ (κ.match_ (W.pairing f)) j) ∈ + F.internalFlags + rw [iterWalk_shift] + exact all_pairings_internal_of_periodic κ hf' (j + 1) + · show iterWalk κ (κ.match_ (W.pairing f)) n = + κ.match_ (W.pairing f) + rw [iterWalk_shift, iterWalk_succ, hperiod] + +/-! ### 2. periodicFlags -/ + +/-- 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 ⊢ + show κ.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 hfi := κ.periodicFlags_sub hf + have hgi := κ.periodicFlags_sub hg + 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 hfi hgi 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 : ℕ) (_hd : 1 ≤ 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) (by omega) + (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) (by omega) + (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) + (_hf : f ∈ F.internalFlags) + (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) (by omega) + (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) (by omega) + (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 + haveI : 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 + show κ.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 + show 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..eca9e07d56 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrbitParities.lean @@ -0,0 +1,397 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.NonSeparatedStep +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. +-/ + +namespace RS + +open scoped Classical + +/-! ## 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 [Fintype 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 + 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 + letI : 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 + letI : 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..9ec615c160 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientExistence.lean @@ -0,0 +1,497 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +open scoped Classical +/-! ## 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 + 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 [dif_pos 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 [dif_neg (fun hf => internal_not_boundary hf hb), dif_pos 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 [dif_neg (fun h1 => hf (mem_flags_of_internalFlags F h1)), + dif_neg (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 + show (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 + show 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 + have hmatch_flip : ∀ g ∈ F.internalFlags, + isOut (κ.match_ g) = !isOut g := by + intro g hg + have hgf : g ∈ F.flags := mem_flags_of_internalFlags F hg + simp only [isOut, dif_pos hgf, + dif_pos (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⟩)) + have hpairing_flip : ∀ g ∈ F.internalFlags, + W.pairing g ∈ F.internalFlags → + isOut (W.pairing g) = !isOut g := by + intro g hg _hpg + have hgf : g ∈ F.flags := mem_flags_of_internalFlags F hg + simp only [isOut, dif_pos hgf, + dif_pos (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⟩)) + exact ⟨isOut, hmatch_flip, hpairing_flip⟩ + +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..8010f4f28e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean @@ -0,0 +1,881 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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). +-/ + +namespace RS + +open scoped Classical + +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 [if_pos (pairing_mem_orientDiff hpair hg), if_pos hg, + φ.prop g] + · rw [if_neg (pairing_notMem_orientDiff hpair hg), if_neg 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) := + if_pos 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 := + if_neg 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 + show (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 [if_pos hg, flipColouring_val_of_mem o o' hpair φ g hg, + oddPartner_invol] + · rw [if_neg 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 [dif_pos + (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 -/ + +/-- 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 + 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 + 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 + 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 + show [(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₂) + show [(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] + +/-- **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 φ _ => ?_)) + show (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 +-- Raised budget: invariance is proved over all internal flags at +-- once, so the summand unfolds for both orientations. +/-- **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 + congr 1 + 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 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..79ff0590a3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairCloseComm.lean @@ -0,0 +1,213 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +namespace RS + +namespace Fragment + +private def pcSwapFun (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. -/ +private def pairCloseSwap (t : ℕ) : + Fin (0 + t) ⊕ Fin (t + 0) ≃ + Fin (0 + t) ⊕ Fin (t + 0) where + toFun := pcSwapFun t + invFun := pcSwapFun t + left_inv x := by + rcases x with a | b <;> simp [pcSwapFun, finCongr] + right_inv x := by + rcases x with a | b <;> simp [pcSwapFun, finCongr] + +/-- The disjoint-union ambients of `pairClose F G` +and `pairClose G F` are related by `pairCloseSwap`. -/ +private 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 + · show (((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 + · show (((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 + show F.circles + G.circles = + G.circles + F.circles + omega + +/-- `mapPairs` through `(pairCloseSwap t).symm` on +the interface pairs yields the swap of each pair. -/ +private theorem mapPairs_pcs_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 pcSwapFun since self-inverse + show (pcSwapFun t (Sum.inl ⟨0 + k.val, _⟩), + pcSwapFun t (Sum.inr ⟨k.val, _⟩)) = + (Sum.inr ⟨k.val, _⟩, + Sum.inl ⟨0 + k.val, _⟩) + simp only [pcSwapFun, 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 := + mapPairs_pcs_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..c5ce8fdc6f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean @@ -0,0 +1,2126 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatusNonsep +import LeanPool.RegtsSevenster.RS.Novel.Skein.FourLabelParity +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`. +-/ + +namespace RS + +open scoped Classical + +/-! ## 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 + +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 [if_pos h1.symm, if_pos h2.symm, if_pos h1, if_pos h2] + · rw [if_neg (fun h => h2 h.symm), if_pos h1.symm, if_pos h1, + if_neg h2] + · rw [if_pos h2.symm, if_neg (fun h => h1 h.symm), if_neg h1, + if_pos h2] + · rw [if_neg (fun h => h2 h.symm), if_neg (fun h => h1 h.symm), + if_neg h1, if_neg 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 [if_pos h1, if_neg 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 [if_neg h1, if_pos 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 [if_neg h1, if_neg 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] + +/-- 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, if_neg (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 [if_pos 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 [if_pos ho, hfc, oddPartner_invol, if_neg hnot] + · have hyes : i ∈ oddCountLabels (p :: L) := + (mem_oddCountLabels_cons hp).mpr (Or.inl ⟨hm, ho⟩) + rw [if_neg ho, hfc, if_pos hyes] + · have hfc : flipColours f p i = f i := by + unfold flipColours + rw [if_neg hm] + by_cases ho : i ∈ oddCountLabels L + · have hyes : i ∈ oddCountLabels (p :: L) := + (mem_oddCountLabels_cons hp).mpr (Or.inr ⟨ho, hm⟩) + rw [if_pos ho, hfc, if_pos hyes] + · have hnot : i ∉ oddCountLabels (p :: L) := by + rw [mem_oddCountLabels_cons hp] + rintro (⟨h, -⟩ | ⟨h, -⟩) + · exact hm h + · exact ho h + rw [if_neg ho, hfc, if_neg hnot] + +end SignAlgebra + +/-! ## Indicator and crossing-symmetry helpers -/ + +section Indicators + +variable {β : Type} + +/-- 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 := + if_neg (fun hc => lt_asymm h hc.1) + have hcond : (if x < y then P else Q) ↔ P := by + rw [if_pos 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 := + if_neg (fun hc => lt_asymm h hc.1) + have hcond : (if x < y then P else Q) ↔ Q := by + rw [if_neg (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 [if_pos h, if_neg (lt_asymm h)] + · rw [if_neg (lt_asymm h), if_pos 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 + show (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 + +-- Raised budget: membership in the symmetric difference is +-- unfolded through the status sets on both sides. +/-- 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 + unfold statusDiff + rw [mem_symmU, prop_ne_iff] + tauto + +/-- 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 [if_pos 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 [if_neg 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 [if_pos 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 [if_neg 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 + +/-- **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 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 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 : 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δ) + -- ═══════ 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 + +/-- **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 + +/-- **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 + 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 + by_cases hsame : o₁.isOut c = o₁.isOut a + · -- ─────── non-separated ─────── + -- 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' + · -- ─────── separated ─────── + -- 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 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..777c6e2625 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingConnectivity.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 +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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..a94724eeed --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSignature.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 +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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] + +/-- **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..b0b5e155b0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSwap.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 +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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..2c354fbe01 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingValue.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 +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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, dif_pos 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, dif_neg h, signedValueAt, dif_neg 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..e7a6b0652d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialClose.lean @@ -0,0 +1,211 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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 show (s + u) ≤ (s + u) + (k.val - s); omega, + by show (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 [dif_pos hb] + · have hb2 : (s + u) ≤ b.val ∧ b.val < (s + u) + t := by + rcases h with h | h + · omega + · exact h + simp only [dif_neg hb, + dif_neg (show ¬ s + (b.val - (s + u)) < s by omega)] + exact Subtype.ext (congrArg Sum.inr (Fin.ext (by + show (s + u) + (s + (b.val - (s + u)) - s) = b.val + omega))) + right_inv k := by + by_cases hk : k.val < s + · simp only [dif_pos hk] + · simp only [dif_neg hk, + dif_neg (show ¬ (s + u) + (k.val - s) < s by omega)] + exact Fin.ext (by + show 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..9d6d7d96fc --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseCompose.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 +-/ + +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. +-/ + +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 ?_)) + · show 0 + j.val = j.val + omega + · rfl + · refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) + (congrArg Sum.inr (Fin.ext ?_)) + · show 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) + show 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) + show 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 show ¬ (pcReshuffle s t u v b).val < u + v + rw [hbv] + show ¬ (u + v) + b.val < u + v + omega)) + show 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]; show u + v ≤ (u + v) + b.val; omega), + finSumFinEquiv_apply_right, + pcSurvEquiv_val_low s t u v b hx hb] + refine Fin.ext ?_ + show 0 + ((pcReshuffle s t u v b).val - (u + v)) = b.val + rw [hbv] + show 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 + show 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 show ¬ (pcReshuffle s t u v b).val < u + v + rw [hbv] + show ¬ (u + v) + (s + (b.val - (s + u))) < u + v + omega)) + show 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] + show 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 ?_ + show 0 + ((pcReshuffle s t u v b).val - (u + v)) = + s + (b.val - (s + u)) + rw [hbv] + show 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..4788d32a0a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean @@ -0,0 +1,536 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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) + · show ((((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 + · show (((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 + · show ((((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 + show 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) + show 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) + show 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 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 := + Fragment.mapPairs_wf eP.symm _ (zClosePairs_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 + show (if h : b.val < s then _ else _ : Fin (s + t)) = _ + rw [dif_pos 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 + show (if h : b.val < s then _ else _ : Fin (s + t)) = _ + rw [dif_neg 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))) + show 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 show 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⟩)) + show 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 ?_ + show 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..3b3830e1c8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathCanon.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientationFlip +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. +-/ + +namespace RS + +open scoped Classical + +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 + 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..30f75f86f9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.RepairInvariance +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. +-/ + +namespace RS + +open scoped Classical + +/-! ## (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⟩ + +/-- 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 [if_neg hnX, if_pos hu, if_pos hw] + · have hX : ChordPairCross x y u w := by + rw [chordPairCross_iff_xor huw hux hwy] + exact Or.inl ⟨hu, hw⟩ + rw [if_pos hX, if_pos hu, if_neg hw] + · have hX : ChordPairCross x y u w := by + rw [chordPairCross_iff_xor huw hux hwy] + exact Or.inr ⟨hw, hu⟩ + rw [if_pos hX, if_neg hu, if_pos 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 [if_neg hnX, if_neg hu, if_neg hw] + +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] + +/-- **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 : 1 ≤ s + 1) (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 + 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 hcont + 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 [if_pos (orbitFlag_match hg hfo), if_pos hfo, + o.match_flip f hf] + · rw [if_neg (fun hcon => hfo (orbitFlag_of_match hg hf hcon)), + if_neg 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 [if_pos (orbitFlag_pairing hfo), if_pos hfo, + o.pairing_flip f hf hp] + · rw [if_neg (fun hcon => hfo (orbitFlag_of_pairing hcon)), + if_neg 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 + show (if OrbitFlag κ g f then !o.isOut f else o.isOut f) = + !o.isOut f + exact if_pos 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 + show (if OrbitFlag κ g f then !o.isOut f else o.isOut f) = + o.isOut f + exact if_neg 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..33bd8aea07 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathMatch.lean @@ -0,0 +1,521 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +namespace RS + +open scoped Classical + +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 [if_neg (not_boundary_of_internal h), dif_pos 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 [if_pos 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 [if_neg hb, dif_neg 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 + +/-- 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⟩ + haveI : 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..ca27d55edd --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PermCompose.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.PermFragment +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceShift +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. +-/ + +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 + · show 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] + · show 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 + · show 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 + · show 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 show ℓ.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..017ebe46ea --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PermFragment.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 +-/ + +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. +-/ + +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 [dif_pos h] + exact congrArg Sum.inr (Fin.ext rfl) + · rw [dif_neg h] + refine congrArg Sum.inr (Fin.ext ?_) + show t + (σ (σ.symm ⟨ℓ.val - t, by have := ℓ.isLt; omega⟩)).val = + ℓ.val + rw [Equiv.apply_symm_apply] + show 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, if_false] at hℓ + subst hℓ + rw [dif_pos a.isLt] + · simp only [if_true] at hℓ + subst hℓ + rw [dif_neg (show ¬ t + (σ a).val < t by omega)] + refine Prod.ext_iff.mpr ⟨?_, rfl⟩ + show 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 show 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 [dif_pos h] + · rw [dif_neg h, dif_neg (by + show ¬ t + (σ ⟨ℓ.val - t, _⟩).val < t + omega)] + refine Fin.ext ?_ + show 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 + show t + _ - t = _ + omega)] + rw [Equiv.symm_apply_apply] + show t + (ℓ.val - t) = ℓ.val + omega + right_inv ℓ := by + dsimp only + by_cases h : ℓ.val < t + · simp only [dif_pos h] + · rw [dif_neg h, dif_neg (by + show ¬ t + (σ.symm ⟨ℓ.val - t, _⟩).val < t + omega)] + refine Fin.ext ?_ + show 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 + show t + _ - t = _ + omega)] + rw [Equiv.apply_symm_apply] + show 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 + · show 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 + show (if h : (⟨k.val, by have := k.isLt; omega⟩ : + Fin (t + t)).val < t then _ else _) = _ + rw [dif_pos (show k.val < t from k.isLt)] + · show 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 + show (if h : (⟨t + k.val, by have := k.isLt; omega⟩ : + Fin (t + t)).val < t then _ else _) = _ + rw [dif_neg (show ¬ t + k.val < t by omega)] + refine Fin.ext ?_ + show 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 show 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..16aa8bf4d6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PropThreeOpen.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairedAssembly +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. +-/ + +namespace RS + +open scoped Classical + +/-- 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..984b1d96af --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean @@ -0,0 +1,1839 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeSum +import LeanPool.RegtsSevenster.RS.Novel.Skein.CutMatching +import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperGram +import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch +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`. +-/ + +namespace RS + +namespace EdgeSubset + +open Classical + +variable {α : Type} + +/-- **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 + +/-- **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 [dif_pos hb, dif_pos hb] + by_cases ht : tl ⟨i, hb⟩ = true + · rw [if_pos ht] + rcases hxi : x i with a | c + · show (1 : ℂ) = legWeight (tl ⟨i, hb⟩) (Sum.inl a) + rfl + · show dualSign ℓ c = legWeight (tl ⟨i, hb⟩) (Sum.inr c) + show dualSign ℓ c = if tl ⟨i, hb⟩ then dualSign ℓ c else 1 + rw [if_pos ht] + · rw [if_neg ht] + rcases hxi : x i with a | c + · rfl + · show (1 : ℂ) = if tl ⟨i, hb⟩ then dualSign ℓ c else 1 + rw [if_neg ht] + · rw [dif_neg hb, dif_neg 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 [dif_pos hbnd] + refine mul_eq_zero_of_right _ (Finset.sum_eq_zero (fun ψ _ => ?_)) + by_cases hev : genEvenBoundaryMatch F (untwistD F tl x) hbnd ψ + · rw [if_pos hev] + exact Finset.sum_eq_zero (fun φ _ => if_neg (fun hφ => + hag (throughAgree_of_edgeOddBoundaryMatch hbnd hφ))) + · rw [if_neg 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 [dif_pos hbnd] + refine mul_eq_zero_of_right _ (Finset.sum_eq_zero (fun ψ _ => ?_)) + by_cases hev : genEvenBoundaryMatch F (untwist F κ o x) hbnd ψ + · rw [if_pos hev] + exact Finset.sum_eq_zero (fun φ _ => if_neg (fun hφ => + hag (throughAgree_of_edgeOddBoundaryMatch hbnd hφ))) + · rw [if_neg 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 dif_neg (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⟩ := dif_pos 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] + show (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 [if_pos ht, if_pos ht] + rcases x i with a | c <;> rfl + · rw [if_neg ht, if_neg ht] + · rw [untwistD_apply_not_mem F tl x hb] + show x i = if legDir F tl i then dualLeg (x i) else x i + rw [show legDir F tl i = false from dif_neg hb, if_neg (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 [dif_pos 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 [if_pos hψ, if_pos hψ] + exact sum_edgeOddColouring hbnd hag + (fun φ' => ∏ v : W.Vertex, + ((F.coreOddSignAt o φ' v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.coreOddListAt o φ' v))) + · rw [if_neg hψ, if_neg 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 [dif_pos 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 [if_pos hψ, if_pos hψ] + exact sum_edgeOddColouring hbnd hag + (fun φ' => ∏ v : W.Vertex, + ((F.coreOddSignAt o φ' v : ℂ) * + h.evalOdd (F.evenColoursAt ψ v) + (F.coreOddListAt o φ' v))) + · rw [if_neg hψ, if_neg 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 [dif_pos h₁, dif_pos h₂, if_pos ⟨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 [dif_neg 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 [dif_pos h₁] + by_cases h₂ : genBoundarySubsetMatches W₂ F₂.flags st + · rw [dif_pos h₂, if_neg (fun hx => hag hx.1)] + · rw [dif_neg 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 [dif_pos h₁, dif_pos h₂, if_neg (fun hx => hag hx.2)] + · rw [dif_neg 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 + show 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 dif_neg (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 dif_neg (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 dif_neg (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 dif_neg (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 [if_pos (heven.mpr hψ), if_pos 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 [if_pos (hcore.mpr hφ), if_pos hφ] + · rw [if_neg (fun hx => hφ (hcore.mp hx)), if_neg hφ] + · rw [if_neg (fun hx => hψ (heven.mp hx)), if_neg 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 [if_pos ht, if_pos ht] + show Sum.inr (oddPartner ℓ (oddPartner ℓ c₁)) = Sum.inr c₁ + rw [oddPartner_invol] + · rw [if_neg ht, if_neg 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 [if_pos ht, if_pos ht] + show Sum.inr (oddPartner ℓ (oddPartner ℓ c₂)) = Sum.inr c₂ + rw [oddPartner_invol] + · rw [if_neg ht, if_neg 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 [if_neg (by simp), Bool.not_false, if_pos rfl] + have hB := dualSign_mul_partner (ℓ := ℓ) c₁ + have hA := dualSign_mul_self (ℓ := ℓ) c₂ + push_cast + linear_combination + (dualSign ℓ c₂ * ((oddPartnerSign ℓ c₂ : ℤ) : ℂ)) * hB - hA + · rw [if_pos rfl, Bool.not_true, if_neg (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 [dif_pos hbi, dif_pos 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, if_neg 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, if_false, Bool.not_false, + if_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 [if_true, Bool.not_true, Bool.false_eq_true, + if_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, if_false, Bool.not_false, + if_true, Sum.map_inr, oddPartner_invol] at hs hs' + exact (Sum.inr.inj hs').symm.trans (Sum.inr.inj hs) + | true => + simp only [hb0, if_true, Bool.not_true, Bool.false_eq_true, + if_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) + · show (e (B.edge (e.symm b))).val = _ + rw [congrFun hBe (e.symm b)] + show (e (e.symm ((cutMatching F₂ κ₂ o₂).edge + (e (e.symm b))))).val = _ + rw [e.apply_symm_apply, e.apply_symm_apply] + rfl + · show 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 + show (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 [dif_pos hi₂, dif_pos 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..a4840980a3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelTransition.lean @@ -0,0 +1,353 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +namespace RS + +open scoped Classical + +variable {α : Type} + +namespace EdgeSubset + +variable {W : Fragment α} + +/-! ## Internal vs boundary flag classification -/ + +/-- 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) + +/-- 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 + +/-- 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) + +/-- 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 + unfold internalFlags boundaryFlags + rw [Finset.disjoint_filter] + intro f _ ⟨v, hv⟩ ⟨i, hi⟩ + rw [hv] at hi; cases hi + +/-- 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 + +/-- 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 + +/-- 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 + +/-- 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 -/ + +/-- 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⟩ + +/-- 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 the pairing of an internal flag is also internal, the walk +stays within internal flags. -/ +theorem RelTransitionSystem.internalWalk_mem {F : EdgeSubset W} + (κ : F.RelTransitionSystem) {f : W.Flag} + (_hf : f ∈ F.internalFlags) + (hp : W.pairing f ∈ F.internalFlags) : + κ.internalWalk f ∈ F.internalFlags := + κ.match_mem _ hp + +/-- The walk map is injective on internal flags (when pairings stay +internal). -/ +theorem RelTransitionSystem.internalWalk_injOn {F : EdgeSubset W} + (κ : F.RelTransitionSystem) {f g : W.Flag} + (_hf : f ∈ F.internalFlags) (_hg : g ∈ F.internalFlags) + (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 hf (κ.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 hf hg + (κ.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 -/ + +/-- 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] + show κ.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..ee9751b2d9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelValue.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition +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. +-/ + +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 + letI := W.flagOrder + letI := 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 + letI := W.flagOrder + letI := 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 + letI := W.flagOrder + letI := 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..61e042b96b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelChords.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelInvariance +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. +-/ + +namespace RS + +open scoped Classical + +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..5f8a366e56 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelInvariance.lean @@ -0,0 +1,617 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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 + show (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 + show (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 + show 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 => + show (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 + letI := (W.relabel ee).flagOrder + letI := 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] + show (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 -/ + +/-- 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..d4ff96d3c1 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RepairInvariance.lean @@ -0,0 +1,918 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionMove +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. +-/ + +namespace RS + +open scoped Classical + +/-! ## 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 + letI := W.flagOrder + letI := 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 + 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 + show κ₂.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 + 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..881d750dd7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidInstance.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 +-/ + +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`). +-/ + +namespace RS + +open CategoryTheory MonoidalCategory + +variable {R : ℕ} (f : EdgeRankParameter R) + +/-- The exact self-pairing at every arity. -/ +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..109d757eee --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidityClasses.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance +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. +-/ + +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 + show Sum.inr (e g) = + ((Sum.inr (e g) : Empty ⊕ Fin 2).map + (_root_.Equiv.refl Empty) id) + rfl + pairing_comm := fun g => by + show 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 ?_ + show (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..9e4fea6355 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarClass.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity +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)`. +-/ + +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 + show 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..eaa2af9e4a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarFunctional.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 +-/ + +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. +-/ + +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..38fab6599e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SeparatedParity.lean @@ -0,0 +1,1802 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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`. +-/ + +namespace RS + +open scoped Classical + +/-! ## (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 [Fintype 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 + 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 [Fintype 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 + 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 [Fintype 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 + 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 [dif_pos 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 [dif_neg 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] + show 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] + show (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 + show κ.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..dec29af885 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SimpleUnit.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity +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`. +-/ + +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..4b4a444ab7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCatInstance.lean @@ -0,0 +1,40 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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..1b95d74025 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCategory.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomCompose +import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic +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. +-/ + +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 + show 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..0e9b38ed99 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdeal.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate +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. +-/ + +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] + show 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..cc138faa2e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdealLeft.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotateLeft +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. +-/ + +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] + show 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..47316d1a5e --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinLinear.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 +-/ + +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. +-/ + +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..997e6adba7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SnakeClasses.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidityClasses +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. +-/ + +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)) + ((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 _ _ + 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)) + ((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 _ _ + 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..143212a22d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarCompClass.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarTrace +import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarFunctional +import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance +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. +-/ + +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..1b8daa0493 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarDecomposition.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarExplode +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. +-/ + +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 + show (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 + show (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 + show (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 dif_neg (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) + haveI : IsEmpty {f : W.Flag // f ∈ C} := + ⟨fun s => hne s.val s.prop⟩ + refine ⟨?_⟩ + show ((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) + haveI : 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 ⟨?_⟩ + show (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)) + show ((⟨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..8da046bad5 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarEnum.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 +-/ + +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. +-/ + +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⟩ := dif_pos h + rw [h1] + rfl + · have h1 : repSplitFun W f = + Sum.inr ⟨W.pairing f, + (mem_or_pairing_mem W f).resolve_left h⟩ := dif_neg h + rw [h1] + exact W.pairing_invol f + right_inv s := by + rcases s with x | x + · show repSplitFun W x.val = Sum.inl x + exact dif_pos x.prop + · show repSplitFun W (W.pairing x.val) = Sum.inr x + exact (dif_neg (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 + show 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⟩ := dif_pos 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 + show 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⟩ := + dif_neg 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 + show 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 + show (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 + haveI := 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 + haveI := 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..87e8349896 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarExplode.lean @@ -0,0 +1,393 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold +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. +-/ + +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 [dif_pos h] + · simp only [dif_neg h, + dif_neg (fun hp => h (hC.pairing_mem.mp hp)), + W.pairing_invol] + · simp only [dif_pos 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 [dif_pos hf] at h' + exact Sum.inr_ne_inl h' + · rw [dif_neg 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) + +/-- **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 := + dif_neg 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 := fun g => by + obtain ⟨gv, hg⟩ := g + rcases gv with f | s + · -- ═══════ An old flag: case-split on the rewire ═══════ + show (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 [dif_pos 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) := dif_neg 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 + show (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 [dif_neg hne₀] + · rw [dif_neg 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 [dif_pos 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 + show (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 [dif_neg hne₁, W.pairing_invol] + · rw [dif_neg 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 [dif_pos 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 dif_pos 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 + dif_pos hmem) + simp only [hp₁] + exact hp₂.symm + · -- f ∉ C → pairing = Sum.inl (W.pairing f) + rw [dif_neg 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 dif_neg 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 dif_neg hne) + simp only [hp₁] + exact hp₂.symm + · -- ═══════ A new star flag ═══════ + show (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 + } + +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..0bcba6ce3b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarPrep.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.StarEnum +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. +-/ + +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 ?_))))⟩ + show 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 + show ((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 + show (strandBundle m).attach (i, !b) = + (((strandBundle m).attach (i, b)).map id + (transposeEquiv m m)).map (_root_.Equiv.refl Empty) id + cases b + · show (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] + · show (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 ?_)) + · show 0 + (m + m - 1 - i) = m + (m - 1 - i) + omega + · show 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 ?_)) + · show 0 + (m + m - 1 - i) = m - 1 - (i - m) + omega + · show 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..0420eede1a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarTrace.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 +-/ + +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. +-/ + +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..c800b20c02 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StateFlipSet.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 +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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) := + if_pos h + +/-- Off it the state is unchanged. -/ +theorem stateOddFlipSet_of_notMem {E : Finset α} {i : α} + (h : i ∉ E) : stateOddFlipSet st E i = st i := + if_neg h + +/-- The empty relabel is the identity. -/ +theorem stateOddFlipSet_empty : + stateOddFlipSet st (∅ : Finset α) = st := by + funext i + exact if_neg (Finset.notMem_empty i) + +/-- 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 + show (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 [if_pos h, if_pos (by + rcases h with rfl | rfl + · exact Finset.mem_insert_self _ _ + · exact Finset.mem_insert_of_mem (Finset.mem_singleton_self _))] + · rw [if_neg h, if_neg (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')))] + +/-- **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 [if_pos h2, if_pos h1, if_neg (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 + · show Sum.inr (oddPartner ℓ (oddPartner ℓ c)) = Sum.inr c + rw [oddPartner_invol] + · rw [if_neg h2, if_pos h1, if_pos + (Finset.mem_union_left _ (Finset.mem_sdiff.mpr ⟨h1, h2⟩))] + · rw [if_pos h2, if_neg h1, if_pos + (Finset.mem_union_right _ (Finset.mem_sdiff.mpr ⟨h2, h1⟩))] + · rw [if_neg h2, if_neg h1, if_neg (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..4c1a16b474 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StatusSet.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.StepFrame +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. +-/ + +namespace RS + +open scoped Classical + +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..9d2e2a3a78 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepFrame.lean @@ -0,0 +1,559 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonicalFrame +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. +-/ + +namespace RS + +open scoped Classical + +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 [if_pos (by rw [if_pos hlt]; exact hhigh)] + rw [Finset.mem_singleton, newLow, if_pos 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 [if_pos (by rw [if_neg hnlt]; exact hhigh)] + rw [Finset.mem_singleton, newLow, if_neg hnlt] + · rcases Finset.mem_insert.mp hx4c with rfl | hx4d + · obtain ⟨hlt, hhigh⟩ := hm₃.mp hx + right + rw [if_pos (by rw [if_pos hlt]; exact hhigh)] + rw [Finset.mem_singleton, newLow, if_pos 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 [if_pos (by rw [if_neg hnlt]; exact hhigh)] + rw [Finset.mem_singleton, newLow, if_neg 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 [if_pos hcond, Finset.mem_singleton] at hx + subst hx + unfold newLow + by_cases hlt : F.boundaryLabel he₁ < F.boundaryLabel he₂ + · rw [if_pos hlt] + rw [if_pos hlt] at hcond + exact hm₁.mpr ⟨hlt, hcond⟩ + · rw [if_neg hlt] + rw [if_neg 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 [if_neg 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 [if_pos hcond, Finset.mem_singleton] at hx + subst hx + unfold newLow + by_cases hlt : F.boundaryLabel (κ.pathMatch_mem he₁) < + F.boundaryLabel (κ.pathMatch_mem he₂) + · rw [if_pos hlt] + rw [if_pos hlt] at hcond + exact hm₃.mpr ⟨hlt, hcond⟩ + · rw [if_neg hlt] + rw [if_neg 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 [if_neg 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..3ce013ff4b --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepLedger.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity +import LeanPool.RegtsSevenster.RS.Novel.Skein.OrbitParities +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. +-/ + +namespace RS + +open scoped Classical + +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..de6ce4b27c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatus.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 +-/ + +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`). +-/ + +namespace RS + +open scoped Classical + +/-! ## 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..56b8427018 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatusNonsep.lean @@ -0,0 +1,414 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +/-! ## 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..acfc075286 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StrandBundle.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 +-/ + +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`). +-/ + +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 [dif_pos h] + exact congrArg Sum.inr (Fin.ext rfl) + · rw [dif_neg h] + refine congrArg Sum.inr (Fin.ext ?_) + show 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, if_false] at hℓ + subst hℓ + rw [dif_pos a.isLt] + · simp only [if_true] at hℓ + subst hℓ + rw [dif_neg (show ¬ t + a.val < t by omega)] + refine Prod.ext_iff.mpr ⟨Fin.ext ?_, rfl⟩ + show 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, dif_pos 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, dif_neg 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..0dfcc418d0 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SumLexOrder.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 +-/ + +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. +-/ + +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. -/ +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 + show 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 + show 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 + show 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 + show ¬ 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..0664034e91 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperGram.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.GramRank +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. +-/ + +namespace RS + +open Classical + +/-- **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 if_neg (fun hb => h (by rw [hb]; rfl)) + · rfl + · rcases v with b | d + · rfl + · show 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 [if_pos hlt] at hpart + rw [if_neg (fun hx => hd (hpart.mpr hx)), + if_neg (by omega)] + · rw [if_neg hlt] at hpart + rw [if_neg (by omega), + if_neg (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 if_pos rfl + · show 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 + show 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 [if_neg (by simp), Bool.not_false, if_pos rfl, hJ, hpart, + if_neg (by simp)] + linear_combination hsq + · rw [if_pos rfl, Bool.not_true, if_neg (by simp), hJ, + if_pos 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 := + if_pos 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 [if_neg (by + rintro ⟨⟨c, hcc⟩, -⟩ + exact Sum.inl_ne_inr hcc)] + show (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 [if_pos ⟨⟨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 [if_neg (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 + · show 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 + show (if b i then dualLeg (untwistState b x i) + else untwistState b x i) = x i + by_cases hb : b i = true + · rw [if_pos hb] + show dualLeg (if b i then dualLeg (x i) else x i) = x i + rw [if_pos hb, dualLeg_involutive (x i)] + · rw [if_neg hb] + show (if b i then dualLeg (x i) else x i) = x i + rw [if_neg 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 + show (∃ 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 + show (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 [if_pos h₂] + by_cases h₁ : b₁ i = true + · rw [if_pos h₁] + · rw [if_neg h₁] + · rw [if_neg h₂] + by_cases h₁ : b₁ i = true + · rw [if_pos h₁] + · rw [if_neg h₁] + · rw [hb i ⟨c, hx⟩] + by_cases h₁ : b₁ i = true + · rw [h₁, Bool.not_true, if_neg (by simp), if_pos rfl] + · have hf : b₁ i = false := by + cases hbb : b₁ i + · rfl + · exact absurd hbb h₁ + rw [hf, Bool.not_false, if_pos rfl, if_neg (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 + show 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 + show 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 + show (∃ 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..bf2f4d2389 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperSpace.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 +-/ + +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`. +-/ + +namespace RS + +open Classical + +/-- **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 [dif_pos h, if_pos h, Fin.ext_iff] + · rw [dif_neg h, if_neg 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 [if_pos h]; norm_num + · rw [if_neg 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 [if_pos h] at hv + rw [if_pos hv, if_pos h] + norm_num + · rw [if_neg h] at hv + rw [if_neg (show ¬ ((oddPartner ℓ c).val = c.val + ℓ) by omega), + if_pos (show c.val = (oddPartner ℓ c).val + ℓ by omega), + if_neg 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..f893286020 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorAssoc.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment +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. +-/ + +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 show a.val = s₁ + (a.val - s₁); omega), + interleaveEquiv_inl_high, interleaveEquiv_inl_high, + interleaveEquiv_inl_high] + exact Fin.ext (by + show ((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 show b.val = s₂ + (b.val - s₂); omega), + interleaveEquiv_inr_high, interleaveEquiv_inl_high, + interleaveEquiv_inl_high, interleaveEquiv_inr_high] + exact Fin.ext (by + show ((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 + show (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 show c.val = s₃ + (c.val - s₃); omega), + interleaveEquiv_inr_high, interleaveEquiv_inr_high, + interleaveEquiv_inr_high] + exact Fin.ext (by + show ((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..6ec36012c2 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorComm.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal +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. +-/ + +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] + show 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..750d4bbb21 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorCompClass.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorInterchange +import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor +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. +-/ + +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..2e595a9e1f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorFragment.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 +-/ + +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. +-/ + +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..8148da64ef --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorIdeal.lean @@ -0,0 +1,1124 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment +import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialClose +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`. +-/ + +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 ?_)) <;> + · show (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) + · show 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) + · show 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) + · show 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) + · show 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) + · show 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) + · show 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) + · show 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) + · show 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 show (s + u) ≤ (s + u) + k.val; omega, + by show (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 + show ((if hk : s + k.val < s then _ else _ : + {x // pcSurvPred s t u v x})).val = _ + rw [dif_neg (show ¬ s + k.val < s by omega)] + exact congrArg Sum.inr (Fin.ext (by + show (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 + show ((if hk : i.val < s then _ else _ : + {x // pcSurvPred s t u v x})).val = _ + rw [dif_pos (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) + show 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) + show 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 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) := + Fragment.mapPairs_wf iM.symm.symm _ wfLift + 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 + show 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 + show 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] + show 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..1694c11202 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean @@ -0,0 +1,730 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment +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. +-/ + +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) + · show (((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 + · show (((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 + · show (((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 + · show (((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 + show 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) + · show (_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] + · show (_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) + · show (_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] + · show (_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 -/ + +/-- **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) + (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 + (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 + apply _root_.Equiv.ext; intro x + have h_sc : surv_c = + (interfaceSurvEquiv (s₁+s₂) (t₁+t₂) + (u₁+u₂)).trans finSumFinEquiv := rfl + cases x with + | inl fs₁ => + 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 + show (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 [h_sc, _root_.Equiv.trans_apply] + refine (congrArg finSumFinEquiv + (interfaceSurvEquiv_inl (s₁+s₂) (t₁+t₂) (u₁+u₂) + _ (ieF (Sum.inl a)) + (by + show 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 + show (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 + show 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 [h_sc, _root_.Equiv.trans_apply] + refine (congrArg finSumFinEquiv + (interfaceSurvEquiv_inr (s₁+s₂) (t₁+t₂) (u₁+u₂) + _ (ieG (Sum.inl b)) + (by + show 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 + show (ieG (Sum.inl b)).val - (t₁ + t₂) = + b.val - t₁ + rw [hie_val] + omega)) + | inr fs₂ => + 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 + show (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 [h_sc, _root_.Equiv.trans_apply] + refine (congrArg finSumFinEquiv + (interfaceSurvEquiv_inl (s₁+s₂) (t₁+t₂) (u₁+u₂) + _ (ieF (Sum.inr c)) + (by + show 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 + show (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 + show 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 [h_sc, _root_.Equiv.trans_apply] + refine (congrArg finSumFinEquiv + (interfaceSurvEquiv_inr (s₁+s₂) (t₁+t₂) (u₁+u₂) + _ (ieG (Sum.inr d)) + (by + show 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 + show (ieG (Sum.inr d)).val - (t₁ + t₂) = + u₁ + (d.val - t₂) + rw [hie_val] + omega)))))) + +/-! ### 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..78425cad40 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorUnit.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 +-/ + +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. +-/ + +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 show 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 show ℓ.val = s + (ℓ.val - s); omega), + interleaveEquiv_inr_high] + exact Fin.ext (by + show (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 show ℓ.val = s + (ℓ.val - s); omega), + interleaveEquiv_inl_high] + exact Fin.ext (by + show (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 + · show (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 + show 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 + · show (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 + show 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..43173b565c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughEdgeCut.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch +import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta +import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge +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. +-/ + +namespace RS + +open scoped Classical + +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..7ff305c936 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughIndCFalse.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 +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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..44dc9a3f94 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughValue.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.RelValue +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. +-/ + +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..1fc61e64f6 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/Trace.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle +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. +-/ + +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..d8425330d3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceCyclic.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate +import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceShift +import LeanPool.RegtsSevenster.RS.Novel.Skein.PairCloseComm +import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw +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. +-/ + +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 show 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 show j.val = 0 + j.val; omega), + outPermEquiv_high 0 e j] + exact Fin.ext (by show (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..84cafaccc3 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceNondegenerate.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic +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. +-/ + +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] + show 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..19ef09bf30 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean @@ -0,0 +1,494 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +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} [DecidableEq β] + (s : Finset β) (hs : Even s.card) : + ∃ m : β → β, (∀ x ∈ s, m x ∈ s) ∧ + (∀ x ∈ s, m (m x) = x) ∧ (∀ x ∈ s, m x ≠ x) := by + 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 + show ((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 [hs'_def, Finset.mem_erase]; exact ⟨h2, h1, hx⟩ + have := hm'_mem x hxs' + simp [hs'_def, Finset.mem_erase] 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 [hs'_def, Finset.mem_erase]; 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 [hs'_def, Finset.mem_erase]; 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 := dif_pos 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 + show 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). -/ +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 +/-- 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, dif_pos hg, dif_pos (κ.match_mem g hg)] + rw [orbitMin_pairing_match ⟨g, hg⟩, orbitMin_match ⟨g, hg⟩] + exact 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, dif_pos hg, dif_pos (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 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..e896f59977 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionMove.lean @@ -0,0 +1,640 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +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. +-/ + +namespace RS + +open scoped Classical + +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 + show 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..211c2a19ea --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransposeLedger.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathStep +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. +-/ + +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 + +open scoped Classical + +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 [if_pos 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 [if_neg hb] + rw [Fintype.sum_eq_single cPhi hzero] + rw [if_pos 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, + if_pos (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, if_pos 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, + if_pos (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, if_pos 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..b8ad27a597 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathNonSep.lean @@ -0,0 +1,1594 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger +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. +-/ + +namespace RS + +open scoped Classical + +/-! ## The two-label `∂`-relabel of a boundary state -/ + +/-- 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₂ : α} + +/-- 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 := + if_neg (fun h => h.elim h1 h2) + +/-- At the first label the state entry is `∂`-flipped. -/ +theorem stateOddFlip_left : + stateOddFlip st i₁ i₂ i₁ = Sum.map id (oddPartner ℓ) (st i₁) := + if_pos (Or.inl rfl) + +/-- At the second label likewise. -/ +theorem stateOddFlip_right : + stateOddFlip st i₁ i₂ i₂ = Sum.map id (oddPartner ℓ) (st i₂) := + if_pos (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 + +/-- 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 [if_pos 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 [if_neg h] + +/-- 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 [if_pos h] + cases hst : st i with + | inl a' => exact Iff.rfl + | inr b => + constructor + · intro hc + cases hc + · intro hc + cases hc + · rw [if_neg 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 + +/-- **The relabel is an involution.** -/ +theorem stateOddFlip_stateOddFlip : + stateOddFlip (stateOddFlip st i₁ i₂) i₁ i₂ = st := by + funext i + show (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 [if_pos h, show stateOddFlip st i₁ i₂ i = + Sum.map id (oddPartner ℓ) (st i) from if_pos h] + cases st i with + | inl a => rfl + | inr b => + show Sum.inr (oddPartner ℓ (oddPartner ℓ b)) = Sum.inr b + rw [oddPartner_invol] + · rw [if_neg 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 [if_pos (h.match_mem f hfS), if_pos hfS, + o.match_flip f hf] + · rw [if_neg (h.match_notMem hf hfS), if_neg 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 [if_pos (h.pairing_mem f hfS hfp₁ hfp₂), if_pos hfS, + o.pairing_flip f hf hp] + · rw [if_neg (h.pairing_notMem hfS + (PortedFlipSet.int_ne_boundaryFlag hf i₁) + (PortedFlipSet.int_ne_boundaryFlag hf i₂)), if_neg 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 := if_pos 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 := if_neg 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, if_pos (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, + if_neg (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 φ _, + if_pos ((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 φ _, + if_pos ((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 φ _, if_neg (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 [dif_pos hcore, dif_pos 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 [dif_pos hcore, dif_pos 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 -/ + +private noncomputable def diffAtP (S : Finset W.Flag) + (vv : W.Vertex) : Finset W.Flag := + S.filter (fun g => W.attach g = Sum.inl vv) + +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 + show [(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₂) + show [(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⟩) := dif_pos 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⟩) := dif_pos h.p₂_core + rw [h3, h1, h2, hval] + +/-! ### The colouring-sum and even-sum identities -/ + +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 φ _ => ?_)) + show (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 [if_pos ((coreOddBoundaryMatch_portColourFlip h st φ).mpr + hO), + if_pos 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 [if_neg (fun hc => + hO ((coreOddBoundaryMatch_portColourFlip h st φ).mp hc)), + if_neg 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) + +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] + show (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 -/ + +/-- **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 [if_pos hE, if_pos ((evenMatch_stateOddFlip hbnd ψ).mpr hE)] + exact phiSum_portFlip h hM st hc₁ hc₂ o (F.evenColoursAt ψ) + · rw [if_neg hE, + if_neg (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..12ae14d598 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathStep.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger +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. +-/ + +namespace RS + +open scoped Classical + +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 + · cases t with + | zero => + rw [iterWalk_zero] at hper + exact Finset.disjoint_left.mp + F.internalFlags_disjoint_boundaryFlags hper.mem_internal hβ + | succ t => + exact not_periodic_of_chain_segment κ hcont hterm + (by omega) 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 [LinearOrder α] {β β' 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 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 + apply not_periodic_of_boundary_chain (κ.repair a b c d v hsq) _ + hYint + 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] + show (κ.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..b815f12071 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexOddSign.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 +-/ + +import LeanPool.RegtsSevenster.RS.Common.ListAttach +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. +-/ + +namespace RS + +open scoped Classical + +variable {α : Type} {W : Fragment α} {F : EdgeSubset W} + {k ℓ : ℕ} {S : Finset W.Flag} + +/-! ## The in-set at a vertex -/ + +/-- 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 := + 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 + letI := W.flagOrder + letI := 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 [dif_pos hcore, dif_pos hcore, hφ' ⟨g, hcore⟩, if_pos 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 [dif_pos hcore, dif_pos hcore, hφ' ⟨g, hcore⟩, if_neg hg] + · rw [dif_neg hcore, dif_neg 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 [dif_pos hg] + unfold oddPartnerSign + by_cases h : (φ.val ⟨g, hg⟩).val < ℓ <;> simp [h] + · rw [dif_neg 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 [dif_pos (F.pairing_mem_coreFlags hg), dif_pos 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 [dif_pos + (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..26fbc51e47 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexSum.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 +-/ + +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. +-/ + +namespace RS + +namespace EdgeSubset + +open Classical + +variable {α : Type} + +/-- **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..7edf8d9ed9 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/QuantSector.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 +-/ + +import LeanPool.RegtsSevenster.RS.TheoremForward +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. +-/ + +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..4d28bda34c --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/StatementConverse.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 +-/ + +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`. +-/ + +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 [dif_pos (fun f hf => absurd hf (Finset.notMem_empty f))] + rw [if_pos (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, dif_pos hne] + unfold EdgeSubset.mixedSummand + have hcirc : ∀ κ : (flaglessEmptySubset W).TransitionSystem, + κ.circuitCount = 0 := by + intro κ + unfold EdgeSubset.TransitionSystem.circuitCount + haveI : 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] + haveI : IsEmpty {f : W.Flag // + f ∉ (flaglessEmptySubset W).flags} := + ⟨fun f => isEmptyElim f.val⟩ + haveI : IsEmpty {f : W.Flag // + f ∈ (flaglessEmptySubset W).flags} := + ⟨fun f => isEmptyElim f.val⟩ + haveI : Subsingleton + ((flaglessEmptySubset W).EvenColouring k) := + ⟨fun a b => Subtype.ext (funext fun f => isEmptyElim f)⟩ + haveI : 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 + haveI : IsEmpty emptyClosedFragment.Flag := + inferInstanceAs (IsEmpty Empty) + haveI : 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..47704803f7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/Summit.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 +-/ + +import LeanPool.RegtsSevenster.RS.TheoremConverse +import LeanPool.RegtsSevenster.RS.TheoremTotal +import LeanPool.RegtsSevenster.RS.TheoremPadding +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`. +-/ + +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..a36df9d73f --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/TheoremConverse.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 +-/ + +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. +-/ + +namespace RS + +open Classical + +/-- 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..b23d9126c7 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/TheoremDimension.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 +-/ + +import LeanPool.RegtsSevenster.RS.TheoremTotal +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`. +-/ + +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..8f6bf859a8 --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/TheoremForward.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 +-/ + +import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexHeart +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. +-/ + +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..550e2dbf7d --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/TheoremPadding.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 +-/ + +import LeanPool.RegtsSevenster.RS.TheoremDimension +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. +-/ + +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 + letI : IsEmpty (circlesClosed c).Flag := inferInstanceAs (IsEmpty Empty) + letI : 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..4e1fc82ffa --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/TheoremQuant.lean @@ -0,0 +1,40 @@ +/- +Copyright (c) 2026 William Whistler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Whistler +-/ + +import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorDischarge +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. +-/ + +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..ef401e636a --- /dev/null +++ b/LeanPool/RegtsSevenster/RS/TheoremTotal.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 +-/ + +import LeanPool.RegtsSevenster.RS.TheoremForward +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. +-/ + +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..de423f1df0 --- /dev/null +++ b/LeanPool/RegtsSevenster/Solution.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 +-/ + +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. +-/ + +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 95e0c8ad83..b930c6b4e0 100644 --- a/LeanPool/projects.yml +++ b/LeanPool/projects.yml @@ -9966,3 +9966,52 @@ projects: msc: - '90C35' - '05C21' + + - 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 + - RS.regts_sevenster_total + - RS.deligne_theorem + 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 From abc9131626825754647e17d2deb4d779553affea Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 21 Sep 2026 18:24:25 +0000 Subject: [PATCH 02/46] Refine full import for Lean 4.34 compatibility and quality checks --- LeanPool/RegtsSevenster.lean | 2 +- .../RegtsSevenster/RS/Assembly/Blueprint.lean | 685 ++++++------------ .../RS/Assembly/BlueprintConverse.lean | 90 +-- .../RS/Assembly/BlueprintDeligne.lean | 60 +- .../RS/Assembly/BlueprintFactorial.lean | 96 +-- .../RS/Assembly/BlueprintSchur.lean | 280 +++---- .../RS/Assembly/BlueprintStatement.lean | 115 +-- .../RS/Classical/Deligne/GammaModule.lean | 1 - .../RS/Classical/Deligne/PointBaseChange.lean | 1 - .../RS/Classical/Deligne/Rappel210.lean | 1 - .../RS/Classical/Deligne/SuperRealize.lean | 1 - .../RS/Novel/Extraction/StdRigid.lean | 4 - LeanPool/projects.yml | 2 - 13 files changed, 430 insertions(+), 908 deletions(-) diff --git a/LeanPool/RegtsSevenster.lean b/LeanPool/RegtsSevenster.lean index 77612bf50f..5a933751dc 100644 --- a/LeanPool/RegtsSevenster.lean +++ b/LeanPool/RegtsSevenster.lean @@ -848,7 +848,7 @@ import LeanPool.RegtsSevenster.Solution Source: url:https://github.com/willwhistler/regts-sevenster Authors: William Whistler Status: verified -Main declarations: `RS.regts_sevenster_characterisation`, `RS.regts_sevenster_total`, `RS.deligne_theorem` +Main declarations: `RS.regts_sevenster_characterisation` Tags: graph-parameters, tensor-categories, partition-functions MSC: 05C50, 18M20 -/ diff --git a/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean b/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean index d1024ae140..fc03fe6153 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean @@ -268,11 +268,9 @@ A tower whose hook-confined characters vanish has vanishing super power sums, which is what makes the trace zeta rational. -/ -/-- info: 'RS.superPowerSums_of_hook_vanishing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.superPowerSums_of_hook_vanishing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.powerSums_zero_of_eventually_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.powerSums_zero_of_eventually_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### Hook confinement and nilpotent traces @@ -281,14 +279,11 @@ to a hook, nilpotents then have vanishing trace, and the trace criterion makes every endomorphism algebra semisimple. -/ -/-- info: 'RS.PermTower.hook_confinement' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.PermTower.hook_confinement' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.FrobeniusTower.traceA_eq_zero_of_isNilpotent' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.FrobeniusTower.traceA_eq_zero_of_isNilpotent' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.isSemisimpleRing_of_trace' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.isSemisimpleRing_of_trace' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### The classical bases @@ -296,11 +291,9 @@ The symplectic and orthonormal standard bases the super model is written in. -/ -/-- info: 'RS.exists_symplectic_basis' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.exists_symplectic_basis' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.exists_orthonormal_basis' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.exists_orthonormal_basis' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### Definition 5 and its transport @@ -308,11 +301,9 @@ The mixed partition value of an edge subset, and its invariance under a fragment equivalence. -/ -/-- info: 'RS.EdgeSubset.mixedSummand_transport' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.mixedSummand_transport' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.mixedPartition_transport' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.mixedPartition_transport' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### The hypothesis class @@ -321,8 +312,7 @@ literature bounds the ranks of the finite submatrices of the connection matrix. The two are the same condition. -/ -/-- info: 'RS.edgeRankBounded_iff_submatrixRank' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.edgeRankBounded_iff_submatrixRank' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### The gluing calculus @@ -330,32 +320,23 @@ Gluing a list of label pairs: permuting the list, appending, normalising an interface, and the existence of transition data. -/ -/-- info: 'RS.Fragment.glueListPerm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.Fragment.glueListPerm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.glueInterfaceNormal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.glueInterfaceNormal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.Fragment.glueListAppend' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.Fragment.glueListAppend' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeRankParameter.val_union' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeRankParameter.val_union' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.exists_transition_orientation' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.exists_transition_orientation' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.RegtsSevensterStatement' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.RegtsSevensterStatement' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.composeStrandBundleLeft' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.composeStrandBundleLeft' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.Fragment.gluePairComm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.Fragment.gluePairComm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.composeStrandBundleRight' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.composeStrandBundleRight' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### Coordinates and the standard model @@ -363,26 +344,19 @@ Contraction families, the standard form and copairing, and the coordinates a nondegenerate pairing gives. -/ -/-- info: 'RS.exists_coordinates' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.exists_coordinates' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.exists_contraction_families' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.exists_contraction_families' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.exists_coordinates_of_snake' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.exists_coordinates_of_snake' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.exists_std_iso' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.exists_std_iso' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.stdCopair_unique' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.stdCopair_unique' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.exists_std_model' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.exists_std_model' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.stdForm_comp_stdCopair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.stdForm_comp_stdCopair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### Gluing across a disjoint union @@ -390,70 +364,50 @@ The glue list distributes over a disjoint union and commutes with swaps and folds — the associativity engine of the category. -/ -/-- info: 'RS.Fragment.glueListDisjUnionLeft' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.Fragment.glueListDisjUnionLeft' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.Fragment.glueListDisjUnionRight' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.Fragment.glueListDisjUnionRight' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.Fragment.glueListSwap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.Fragment.glueListSwap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.composeAssoc' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.composeAssoc' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.pairCloseComposeRotate' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.pairCloseComposeRotate' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.pairCloseComposeRotateLeft' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.pairCloseComposeRotateLeft' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.composeFinsupp_ker_left' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.composeFinsupp_ker_left' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.composeFinsupp_ker_right' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.composeFinsupp_ker_right' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.HomSpace.comp_ofFragment' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.HomSpace.comp_ofFragment' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.HomSpace.comp_assoc' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.HomSpace.comp_assoc' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.HomSpace.comp_id_left' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.HomSpace.comp_id_left' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.HomSpace.comp_id_right' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.HomSpace.comp_id_right' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.HomSpace.eq_zero_of_traces_vanish' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.HomSpace.eq_zero_of_traces_vanish' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.skeinCategory' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.skeinCategory' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.starDecomposition' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.starDecomposition' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.homSpace_zero_spanned' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.homSpace_zero_spanned' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.interfaceShift' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.interfaceShift' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.Fragment.pairCloseComm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- 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. -/ -/-- info: 'RS.ExactPairing.map' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.ExactPairing.map' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.braided_std_model' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.braided_std_model' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### The trace calculus @@ -461,38 +415,27 @@ Closing a fragment against the strand bundle: relabels cross it, tensors absorb, and permutation fragments compose. -/ -/-- info: 'RS.pairCloseRelabel' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.pairCloseRelabel' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.fragTrace_comm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.fragTrace_comm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.permFragmentCompose' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.permFragmentCompose' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.mem_ker_of_traces_vanish' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.mem_ker_of_traces_vanish' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.pairCloseTensorAbsorb' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.pairCloseTensorAbsorb' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.tensorFinsupp_ker_left' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.tensorFinsupp_ker_left' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.tensorFinsupp_ker_right' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.tensorFinsupp_ker_right' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.HomSpace.tensor_ofFragment' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.HomSpace.tensor_ofFragment' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.tensorFragmentAssoc' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.tensorFragmentAssoc' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.tensorFragmentUnitLeft' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.tensorFragmentUnitLeft' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.tensorFragmentUnitRight' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.tensorFragmentUnitRight' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### The braided envelope @@ -500,17 +443,13 @@ The Karoubi and matrix envelopes inherit the braiding and its symmetry. -/ -/-- info: 'RS.karoubiBraided' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.karoubiBraided' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.karoubiSymmetric' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.karoubiSymmetric' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.matBraided' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.matBraided' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.matSymmetric' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.matSymmetric' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### The skein category @@ -518,71 +457,49 @@ Linear, monoidal and rigid structure on the skein category, and the trace map it carries. -/ -/-- info: 'RS.skeinPreadditive' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.skeinPreadditive' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.skeinLinear' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.skeinLinear' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.HomSpace.traceMap_comp_comm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.HomSpace.traceMap_comp_comm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.partialCloseTensor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.partialCloseTensor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.pairCloseUnionRight' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.pairCloseUnionRight' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.fragTrace_tensor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.fragTrace_tensor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.composeRelabelOut' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.composeRelabelOut' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.composePermFragment' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.composePermFragment' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.partialCloseEqCompose' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.partialCloseEqCompose' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.ofFragment_eq_smul_empty' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.ofFragment_eq_smul_empty' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.pairCloseStrandBundle' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.pairCloseStrandBundle' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.starDecomposition' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.starDecomposition' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.snake_left' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.snake_left' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.snake_right' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.snake_right' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.braid_comp_evClass' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.braid_comp_evClass' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.Fragment.tensorComposeInterchange' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.Fragment.tensorComposeInterchange' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.skeinMonoidal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.skeinMonoidal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.skeinBraided' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.skeinBraided' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.skeinSymmetric' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.skeinSymmetric' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.strandExactPairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.strandExactPairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.strand_ev_symmetry' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.strand_ev_symmetry' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.star_comp_class' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.star_comp_class' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### The coordinate model @@ -590,167 +507,113 @@ The fibre functor's image of a star, the standard model it is identified with, and the transport between them. -/ -/-- info: 'RS.omega_star_scalar' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.omega_star_scalar' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.skein_std_model' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.skein_std_model' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.starUnionFactor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.starUnionFactor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.starClass_factor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.starClass_factor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.omegaVec_tensor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.omegaVec_tensor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.parameter_star_factor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.parameter_star_factor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.circleVal_model' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.circleVal_model' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.stdFromOmega_stdToOmega' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.stdFromOmega_stdToOmega' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.adjWord_spec' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.adjWord_spec' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.stdToOmega_powBraid' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.stdToOmega_powBraid' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.stdToOmega_bmc_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.stdToOmega_bmc_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.bundleCapClass_peel' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.bundleCapClass_peel' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.point_cotensor' depends on axioms: [propext, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.point_cotensor' depends on axioms: [propext, Quot.sound] -/ -/-- info: 'RS.omegaFun_tensor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.omegaFun_tensor' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.evForm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.evForm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.vertexStarClass_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.vertexStarClass_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.stdToOmega_merge' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.stdToOmega_merge' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.stdToOmega_modelStarVec' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.stdToOmega_modelStarVec' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.toColour_whisker' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.toColour_whisker' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.parameter_model' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.parameter_model' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.colourExtend_colourSwap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.colourExtend_colourSwap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.colourSwapWord_evenMap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.colourSwapWord_evenMap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.parameter_capVal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.parameter_capVal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.ClosedFragment.eulerian_transition_nonempty' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.ClosedFragment.eulerian_transition_nonempty' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.omegaFun_capTensor_merge' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.omegaFun_capTensor_merge' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.omegaFun_tensor_oddPair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.omegaFun_tensor_oddPair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.colourMerge_coord' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.colourMerge_coord' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.colourMerge_coord_oddPair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.colourMerge_coord_oddPair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.coordOf_modelStarVec' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.coordOf_modelStarVec' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.evenBasisVec_split' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.evenBasisVec_split' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.evFormOdd' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.evFormOdd' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.stdToOmega_one' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.stdToOmega_one' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.stdToOmega_one_even' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.stdToOmega_one_even' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.stdToOmega_one_odd' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.stdToOmega_one_odd' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.evenBasisVec_one' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.evenBasisVec_one' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.oddBasisVec_one' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.oddBasisVec_one' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.stdForm_evenPair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.stdForm_evenPair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.stdForm_oddPair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.stdForm_oddPair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.omegaFun_ev_basis' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.omegaFun_ev_basis' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.capVal_expansion' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.capVal_expansion' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.splitCapVal_expansion' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.splitCapVal_expansion' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.splitCapVal_merge' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.splitCapVal_merge' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.capVal_succ' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.capVal_succ' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.coordOf_evenBasisVec' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.coordOf_evenBasisVec' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.splitCapVal_oddMerge' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.splitCapVal_oddMerge' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.peelColour_spec' depends on axioms: [propext, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.peelColour_spec' depends on axioms: [propext, Quot.sound] -/ -/-- info: 'RS.eq_peelColour_of' depends on axioms: [propext, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.eq_peelColour_of' depends on axioms: [propext, Quot.sound] -/ -/-- info: 'RS.peelColour_isEven' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.peelColour_isEven' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.pairing_starFlagEnum_symm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.pairing_starFlagEnum_symm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.powMerge_topBraid' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.powMerge_topBraid' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.wordSign_eq_oddInversions' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.wordSign_eq_oddInversions' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.toColour_topBraid' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.toColour_topBraid' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.toColour_powBraid' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.toColour_powBraid' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.toColour_powBraidWord' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.toColour_powBraidWord' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### The master colour sum @@ -759,270 +622,183 @@ diagonal cap pairing, every sign family, and the reindexing that turns the sum into Definition 5. -/ -/-- info: 'RS.wordPerm_adjWord' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.wordPerm_adjWord' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.coordOf_modelPermMap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.coordOf_modelPermMap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.coordOf_modelPermMap'' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.coordOf_modelPermMap'' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.capVal_closed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.capVal_closed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.parameter_colour_sum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.parameter_colour_sum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.starVec_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.starVec_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.stdFromOmega_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.stdFromOmega_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.starCoord_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.starCoord_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.oddInversions_adjacent' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.oddInversions_adjacent' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.starCoord_repeat_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.starCoord_repeat_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.parameter_masterSummand' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.parameter_masterSummand' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.masterSum_partition' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.masterSum_partition' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.colourFlags_pairing_mem' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.colourFlags_pairing_mem' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.colourFlags_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.colourFlags_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.card_even' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.card_even' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.colouringOf_isEven' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.colouringOf_isEven' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.colouringOf_diagonal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.colouringOf_diagonal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.blockRestrict_parity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.blockRestrict_parity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.masterSummand_vanish_of_block_odd' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.masterSummand_vanish_of_block_odd' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.masterSummand_vanish_of_not_eulerian' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.masterSummand_vanish_of_not_eulerian' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.mem_colourFlags_iff' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.mem_colourFlags_iff' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.starFlagEnum_pairing_low' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.starFlagEnum_pairing_low' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.starFlagEnum_pairing_high' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.starFlagEnum_pairing_high' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.oddDataOf_constancy' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.oddDataOf_constancy' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.evenDataOf_constancy' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.evenDataOf_constancy' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.betaDiag_eq_betaColour' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.betaDiag_eq_betaColour' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.betaColour_perm'' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.betaColour_perm'' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.masterSummand_vanish_of_impure' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.masterSummand_vanish_of_impure' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.masterSummand_vanish_of_not_closed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.masterSummand_vanish_of_not_closed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.colouringOf_reconstruct' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.colouringOf_reconstruct' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.oddColouringOf_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.oddColouringOf_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.evenColouringOf_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.evenColouringOf_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.masterSummand_vanish_of_not_diagonal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.masterSummand_vanish_of_not_diagonal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.pairPure_of_pattern_closed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.pairPure_of_pattern_closed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.fibreSum_eq_dataSum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.fibreSum_eq_dataSum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.koszulCrossings_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.koszulCrossings_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.image_blockFlag' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.image_blockFlag' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.blockRestrict_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.blockRestrict_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.blockRestrict_colouringOf_isRight' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.blockRestrict_colouringOf_isRight' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.repFlag_pairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.repFlag_pairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.outRepSet_pairing_mem' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.outRepSet_pairing_mem' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.colourFormEntry_inr_partner' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.colourFormEntry_inr_partner' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.betaDiag_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.betaDiag_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.evenColoursAt_blockVertex' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.evenColoursAt_blockVertex' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.OddColouring.sum_flip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.OddColouring.sum_flip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.blockRestrict_colouringOfFlip_mem' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.blockRestrict_colouringOfFlip_mem' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.map_flagsAt_blockVertex' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.map_flagsAt_blockVertex' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.oddInversions_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.oddInversions_colouringOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.sortSign_ofFn_comp_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.sortSign_ofFn_comp_perm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.prod_out_sign_eq_prod_edges' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.prod_out_sign_eq_prod_edges' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.edge_sign_sector' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.edge_sign_sector' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.oddListAt_coe_multiset' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.oddListAt_coe_multiset' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.prod_oddSignAt' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.prod_oddSignAt' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.betaDiag_colouringOfFlip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- 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] -/ -#guard_msgs in -/-- info: 'RS.EdgeSubset.TransitionSystem.neg_one_pow_circuitCount' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.TransitionSystem.neg_one_pow_circuitCount' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.oddListAt_eq_map' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.oddListAt_eq_map' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.pairFlagList_nodup' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.pairFlagList_nodup' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.mem_blockOddFlagList_iff_pairFlagList' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.mem_blockOddFlagList_iff_pairFlagList' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.prod_blockVertex' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.prod_blockVertex' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.sortSign_map_listIndexPerm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.sortSign_map_listIndexPerm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.sign_listIndexPerm_trans' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.sign_listIndexPerm_trans' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.sortSign_pairFlagList_key' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.sortSign_pairFlagList_key' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.exists_canonPerm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.exists_canonPerm' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.oddListOf_blockRestrict' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.oddListOf_blockRestrict' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.evenMultisetOf_blockRestrict' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.evenMultisetOf_blockRestrict' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.starCoord_block_flip_nodup' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.starCoord_block_flip_nodup' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.starCoord_block_flip_not_nodup' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.starCoord_block_flip_not_nodup' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.oddListOf_blockRestrict_eq_map' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.oddListOf_blockRestrict_eq_map' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.vertex_sign_collapse' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.vertex_sign_collapse' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.patternOddInv_eq_inversions' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.patternOddInv_eq_inversions' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.sortSign_globalPairList' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.sortSign_globalPairList' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.sign_listIndexPerm_slot_edge' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.sign_listIndexPerm_slot_edge' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.sign_listIndexPerm_edge_oriented' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.sign_listIndexPerm_edge_oriented' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.hMaster_vertex_nodup' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.hMaster_vertex_nodup' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.defFiveNF_eq_flip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.defFiveNF_eq_flip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.sign_listIndexPerm_oriented_matched' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.sign_listIndexPerm_oriented_matched' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.sign_listIndexPerm_matched_global' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.sign_listIndexPerm_matched_global' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.core_parity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.core_parity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.grand_parity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.grand_parity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.masterSummand_colouringOfFlip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.masterSummand_colouringOfFlip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.fibreSum_eq' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.fibreSum_eq' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.parameter_eq_mixedPartition' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.parameter_eq_mixedPartition' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.hMaster_colouringOfFlip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.hMaster_colouringOfFlip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.mixedSummand_eq_nf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.mixedSummand_eq_nf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.eulerian_independence_closed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.eulerian_independence_closed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.mixedValue_eq_summand_closed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.mixedValue_eq_summand_closed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### Deligne's hypotheses for the envelope @@ -1030,19 +806,14 @@ Each hypothesis of the cited theorem, discharged for the concrete envelope, and the package they assemble into. -/ -/-- info: 'RS.env_deligneSemisimple' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.env_deligneSemisimple' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.env_deligneGenerated' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.env_deligneGenerated' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.env_deligneModerateGrowth' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.env_deligneModerateGrowth' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.env_delignePackage' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.env_delignePackage' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.skein_delignePackage' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- 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 index 3721d40cab..339f2e01bd 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintConverse.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintConverse.lean @@ -24,8 +24,7 @@ that records them, extended by the identity off the used labels, is what the Koszul sign is read from. -/ -/-- info: 'RS.EdgeSubset.pathMatch_eq_pairing_of_boundary' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- 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 @@ -54,24 +53,19 @@ is what the Koszul sign is read from. -- genuine chords are the subset's and whose fixed points are the -- unused labels. This is what the restriction transports apply to. -/-- info: 'RS.EdgeSubset.boundaryFlag_chordInv' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.boundaryFlag_chordInv' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.chordInv_mem' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.chordInv_mem' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.chordInv_invol' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.chordInv_invol' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.chordInv_ne' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- 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. -/-- info: 'RS.EdgeSubset.boundaryLabel_boundaryFlag' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- 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 @@ -84,17 +78,13 @@ The connection matrix of a parameter with a super Gram factorization has bounded rank, which is the converse's engine. -/ -/-- info: 'RS.converse_of_superGram' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.converse_of_superGram' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.converse_of_superGramIdentity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.converse_of_superGramIdentity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.exists_sum_sum_superForm_tFull' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.exists_sum_sum_superForm_tFull' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.exists_sum_sum_superForm_tensorTermAt' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.exists_sum_sum_superForm_tensorTermAt' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### The interface lift @@ -103,38 +93,27 @@ and back down: the lift, the two glue branches, and the round trip on directions and on the matching. -/ -/-- info: 'RS.EdgeSubset.sign_composition_pair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.sign_composition_pair' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.chainDir_pushData_alternates' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.chainDir_pushData_alternates' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.edgeSum_closeBase_eq_pairAgreeValue' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.edgeSum_closeBase_eq_pairAgreeValue' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.liftData' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.liftData' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.glueDataOpen' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.glueDataOpen' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.glueDataClosed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.glueDataClosed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.match_unglue_glueDataOpen' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.match_unglue_glueDataOpen' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.isOut_unglue_glueDataOpen' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.isOut_unglue_glueDataOpen' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.match_unglue_glueDataClosed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.match_unglue_glueDataClosed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.isOut_unglue_glueDataClosed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.isOut_unglue_glueDataClosed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.edgeTermAt_pushData_colourSum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.edgeTermAt_pushData_colourSum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### The base sum and the converse @@ -142,26 +121,19 @@ The subset sum over the composition's base, its independence of the free bits, and the theorems of record. -/ -/-- info: 'RS.EdgeSubset.summandSum_bits_indep' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.summandSum_bits_indep' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.baseSumBitsOf_all' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.baseSumBitsOf_all' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.baseSumIsClosure_all' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.baseSumIsClosure_all' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.superGramIdentity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.superGramIdentity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.regts_sevenster_converse' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.regts_sevenster_converse' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.regts_sevenster_iff' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.regts_sevenster_iff' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.regts_sevenster_quant_roundtrip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.regts_sevenster_quant_roundtrip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### Definition 5, evaluated @@ -173,8 +145,6 @@ adjoining a free circle sends the same functional to `0`, which fixes the loop/free-circle distinction. -/ -/-- info: 'RS.mixedPartition_loopGraph' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.mixedPartition_loopGraph' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.mixedPartition_loopGraphCircle' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- 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 index f0effe779a..5597ff341f 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintDeligne.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintDeligne.lean @@ -20,68 +20,48 @@ namespace RS /-! ### Deligne's theorem -/ -/-- info: 'RS.deligne_theorem' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.deligne_theorem' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.braidedFibreHypothesis' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.braidedFibreHypothesis' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.exists_splitting_simple_algebra_doubled' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.exists_splitting_simple_algebra_doubled' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.exists_simple_quotient' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.exists_simple_quotient' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### The summit, unconditionally -/ -/-- info: 'RS.regts_sevenster' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.regts_sevenster' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.regts_sevenster_quant' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.regts_sevenster_quant' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.regts_sevenster_total' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.regts_sevenster_total' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.regts_sevenster_characterisation' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.regts_sevenster_characterisation' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.regts_sevenster_quant_characterisation' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.regts_sevenster_quant_characterisation' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### Minimum dimensions, growth and padding -/ -/-- info: 'RS.minimumColourDimension_le_of_represents' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.minimumColourDimension_le_of_represents' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.TotalBoundedMixedModel.dimension_eq_minimum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.TotalBoundedMixedModel.dimension_eq_minimum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.stdModel_dimension_eq_minimum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.stdModel_dimension_eq_minimum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.stdModel_connectionRank_growth' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.stdModel_connectionRank_growth' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.MixedColourEmbedding.mixedPartition_extendColours' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.MixedColourEmbedding.mixedPartition_extendColours' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.MixedFunctional.padColours_represents' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.MixedFunctional.padColours_represents' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.TotalBoundedMixedModel.even_dimension_eq' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.TotalBoundedMixedModel.even_dimension_eq' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.TotalBoundedMixedModel.half_odd_dimension_eq' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.TotalBoundedMixedModel.half_odd_dimension_eq' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.regts_sevenster_minimum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.regts_sevenster_minimum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.regts_sevenster_rank_growth' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.regts_sevenster_rank_growth' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.regts_sevenster_prescribed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- 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 index 5448f69a67..b6dab7fbd6 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintFactorial.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintFactorial.lean @@ -31,19 +31,16 @@ namespace RS /-! ### Statements -/ -/-- info: @SinglePowerTrace : {A : Type u_1} → [inst : Ring A] → [inst_1 : Algebra ℂ A] → (A →ₗ[ℂ] ℂ) → A → Prop -/ -#guard_msgs in +/- Upstream audit output: @SinglePowerTrace : {A : Type u_1} → [inst : Ring A] → [inst_1 : Algebra ℂ A] → (A →ₗ[ℂ] ℂ) → A → Prop -/ -/-- info: @SinglePowerTrace.mk : ∀ {A : Type u_1} [inst : Ring A] [inst_1 : Algebra ℂ A] {τ : A →ₗ[ℂ] ℂ} {y : A}, +/- 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 -/ -#guard_msgs in -/-- info: CycleTraceTower : (E : ℕ → Type u_1) → +/- 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) -/ -#guard_msgs in -/-- info: @CycleTraceTower.mk : {E : ℕ → Type u_1} → +/- Upstream audit output: @CycleTraceTower.mk : {E : ℕ → Type u_1} → [inst : (n : ℕ) → Ring (E n)] → [inst_1 : (n : ℕ) → Algebra ℂ (E n)] → {A : Type u_2} → @@ -58,25 +55,21 @@ namespace RS (Multiset.map (fun c => traceA (g ^ c)) π.cycleType).prod * traceA g ^ (n - π.cycleType.sum)) → CycleTraceTower E A -/ -#guard_msgs in -/-- info: @CycleTraceTower.factorial_le_finrank : ∀ {E : ℕ → Type u_1} [inst : (n : ℕ) → Ring (E n)] +/- 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) -/ -#guard_msgs in -/-- info: @CycleTraceTower.traceA_eq_zero_of_finrank_lt_factorial : ∀ {E : ℕ → Type u_1} [inst : (n : ℕ) → Ring (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 -/ -#guard_msgs in -/-- info: @CycleTraceTower.traceA_eq_zero_of_exponential_bound : ∀ {E : ℕ → Type u_1} [inst : (n : ℕ) → Ring (E n)] +/- 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 -/ -#guard_msgs in -/-- info: @scalarTrace_eq_zero_of_finrank_lt_factorial : ∀ {A : Type u_2} [inst : CategoryTheory.Category.{u_1, u_2} A] +/- 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] @@ -84,9 +77,8 @@ namespace RS [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 -/ -#guard_msgs in -/-- info: @scalarTrace_eq_zero_of_isNilpotent_factorial : ∀ {A : Type u_2} [inst : CategoryTheory.Category.{u_1, u_2} A] +/- 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] @@ -94,81 +86,63 @@ namespace RS [∀ (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 -/ -#guard_msgs in -/-- info: @skeinTrace_eq_zero_of_isNilpotent_factorial : ∀ {R : ℕ} (f : EdgeRankParameter R) (n : ℕ) {g : skeinEnd f n}, +/- 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 -/ -#guard_msgs in -/-- info: @skeinEnd_isSemisimpleRing_factorial : ∀ {R : ℕ} (f : EdgeRankParameter R) (n : ℕ), IsSemisimpleRing (skeinEnd f n) -/ -#guard_msgs in +/- Upstream audit output: @skeinEnd_isSemisimpleRing_factorial : ∀ {R : ℕ} (f : EdgeRankParameter R) (n : ℕ), IsSemisimpleRing (skeinEnd f n) -/ -/-- info: @karoubiEnd_isSemisimpleRing_factorial : ∀ {R : ℕ} (f : EdgeRankParameter R) +/- Upstream audit output: @karoubiEnd_isSemisimpleRing_factorial : ∀ {R : ℕ} (f : EdgeRankParameter R) (X : CategoryTheory.Idempotents.Karoubi (SkeinObj f)), IsSemisimpleRing (CategoryTheory.End X) -/ -#guard_msgs in -/-- info: @karoubiEnd_isSemisimpleRing : ∀ {R : ℕ} (f : EdgeRankParameter R) +/- Upstream audit output: @karoubiEnd_isSemisimpleRing : ∀ {R : ℕ} (f : EdgeRankParameter R) (X : CategoryTheory.Idempotents.Karoubi (SkeinObj f)), IsSemisimpleRing (CategoryTheory.End X) -/ -#guard_msgs in -/-- info: @matTrace_eq_zero_of_isNilpotent' : ∀ {R : ℕ} {f : EdgeRankParameter R} +/- 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 -/ -#guard_msgs in -/-- info: @envEnd_isSemisimpleRing : ∀ {R : ℕ} (f : EdgeRankParameter R) (E : Env f), IsSemisimpleRing (CategoryTheory.End E) -/ -#guard_msgs in +/- Upstream audit output: @envEnd_isSemisimpleRing : ∀ {R : ℕ} (f : EdgeRankParameter R) (E : Env f), IsSemisimpleRing (CategoryTheory.End E) -/ -/-- info: @envAbelian : {R : ℕ} → (f : EdgeRankParameter R) → CategoryTheory.Abelian (Env f) -/ -#guard_msgs in +/- Upstream audit output: @envAbelian : {R : ℕ} → (f : EdgeRankParameter R) → CategoryTheory.Abelian (Env f) -/ -/-- info: @env_deligneSemisimple : ∀ {R : ℕ} (f : EdgeRankParameter R), IsSemisimple (Env f) -/ -#guard_msgs in +/- Upstream audit output: @env_deligneSemisimple : ∀ {R : ℕ} (f : EdgeRankParameter R), IsSemisimple (Env f) -/ -/-- info: @env_delignePackage : ∀ {R : ℕ} (f : EdgeRankParameter R), DeligneTheoremStatement → Nonempty (DelignePackage (Env f)) -/ -#guard_msgs in +/- Upstream audit output: @env_delignePackage : ∀ {R : ℕ} (f : EdgeRankParameter R), DeligneTheoremStatement → Nonempty (DelignePackage (Env f)) -/ -/-- info: @skein_delignePackage : ∀ {R : ℕ} (f : EdgeRankParameter R), +/- Upstream audit output: @skein_delignePackage : ∀ {R : ℕ} (f : EdgeRankParameter R), DeligneTheoremStatement → Nonempty (DelignePackage (SkeinObj f)) -/ -#guard_msgs in /-! ### Axioms -/ -/-- info: 'RS.exists_singlePowerTrace_pow' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.exists_singlePowerTrace_pow' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.linearIndependent_of_group_trace' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.linearIndependent_of_group_trace' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.CycleTraceTower.factorial_le_finrank' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.CycleTraceTower.factorial_le_finrank' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.CycleTraceTower.traceA_eq_zero_of_finrank_lt_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.CycleTraceTower.traceA_eq_zero_of_finrank_lt_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.CycleTraceTower.traceA_eq_zero_of_exponential_bound' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.CycleTraceTower.traceA_eq_zero_of_exponential_bound' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.scalarTrace_eq_zero_of_finrank_lt_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.scalarTrace_eq_zero_of_finrank_lt_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.scalarTrace_eq_zero_of_isNilpotent_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.scalarTrace_eq_zero_of_isNilpotent_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.skeinTrace_eq_zero_of_isNilpotent_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.skeinTrace_eq_zero_of_isNilpotent_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.skeinEnd_isSemisimpleRing_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.skeinEnd_isSemisimpleRing_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.karoubiEnd_isSemisimpleRing_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.karoubiEnd_isSemisimpleRing_factorial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.envAbelian' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- 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 @@ -266,4 +240,6 @@ run_elab do 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 index 0ed7d23a71..2ed22183be 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean @@ -25,40 +25,29 @@ the branching containment, the block faithfulness and the square growth bound — the fields of `SchurPackage`, and the package. -/ -/-- info: 'RS.jtChar_frobenius'' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.jtChar_frobenius'' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.jtChar_orthonormal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.jtChar_orthonormal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.jtChar_eq_nChar' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.jtChar_eq_nChar' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.nProjector_block_faithful' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.nProjector_block_faithful' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.square_growth' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.square_growth' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.branching_of_pairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.branching_of_pairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.jtChar_pad' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.jtChar_pad' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.schurPackageOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.schurPackageOf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.restrPairing_ne_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.restrPairing_ne_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.schurPackage' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.schurPackage' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### The forward theorem on Deligne alone -/ -/-- info: 'RS.regts_sevenster_deligne_only' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.regts_sevenster_deligne_only' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### The trace zeta function @@ -67,14 +56,11 @@ series of its super power sums, and rational when the characters are hook-confined. -/ -/-- info: 'RS.FrobeniusTower.traceZeta_rational' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.FrobeniusTower.traceZeta_rational' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.FrobeniusTower.traceZeta_superSpectrum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.FrobeniusTower.traceZeta_superSpectrum' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.traceZeta_eq_newtonH_series' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.traceZeta_eq_newtonH_series' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### Corollary A.2 with the sharp threshold @@ -82,17 +68,13 @@ The appendix's own statement: a real dimension bound `A`, every side `s > 2e√A`, and degrees at most `s − 1`. -/ -/-- info: 'RS.FrobeniusTower.traceZeta_rational_sharp' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.FrobeniusTower.traceZeta_rational_sharp' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.FrobeniusTower.traceZeta_superSpectrum_sharp' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.FrobeniusTower.traceZeta_superSpectrum_sharp' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.PermTower.hook_confinement_sharp' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.PermTower.hook_confinement_sharp' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.newtonH_series_rational_of_hook_vanishing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.newtonH_series_rational_of_hook_vanishing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### Hook-confined sequences @@ -106,7 +88,6 @@ info: RS.newtonH_series_rational_of_hook_vanishing {t : ℕ → ℂ} {a b : ℕ} ∃ P Q, P.coeff 0 = 1 ∧ Q.coeff 0 = 1 ∧ P.natDegree ≤ b ∧ Q.natDegree ≤ a ∧ IsCoprime P Q ∧ RS.newtonHSeries t * ↑Q = ↑P -/ -#guard_msgs in /-- info: RS.superPowerSums_of_hook_vanishing {t : ℕ → ℂ} {a b : ℕ} @@ -119,7 +100,6 @@ info: RS.superPowerSums_of_hook_vanishing {t : ℕ → ℂ} {a b : ℕ} (∀ x ∈ α, x ∉ β) ∧ ∀ (m : ℕ), 1 ≤ m → t m = (Multiset.map (fun x => x ^ m) α).sum - (Multiset.map (fun x => x ^ m) β).sum -/ -#guard_msgs in /-! ### The separate-sector dimension bound @@ -127,47 +107,33 @@ The `⌊2eR⌋` bound: a square diagram past it is dead, its idempotent acts as zero, and the surviving sector is bounded. -/ -/-- info: 'RS.square_growth_sharp' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.square_growth_sharp' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.PermTower.not_alive_square_sharp' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.PermTower.not_alive_square_sharp' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.skeinRep_square_dead' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.skeinRep_square_dead' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.functional_charIdempotent_signed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.functional_charIdempotent_signed' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.charIdempotent_image_ne_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.charIdempotent_image_ne_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.RelTransitionSystem.pathMatch_invol' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.RelTransitionSystem.pathMatch_invol' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.superPermAction_square_dead' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.superPermAction_square_dead' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.mixedPartition_empty' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.mixedPartition_empty' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.squareSectorBound_of_detPos' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.squareSectorBound_of_detPos' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.diagramSchur_square_const_ne_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.diagramSchur_square_const_ne_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.regts_sevenster_quant_of_detPos' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.regts_sevenster_quant_of_detPos' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.squareBinomialDetPos' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.squareBinomialDetPos' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.det_binomial_upper_ne_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.det_binomial_upper_ne_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.regts_sevenster_quant_deligne_only' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.regts_sevenster_quant_deligne_only' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### The total dimension bound @@ -176,26 +142,19 @@ bound the commutant by a polynomial. The transported colour action then forces `k + 2 * ℓ ≤ R` by comparison of exponential bases. -/ -/-- info: 'RS.nDim_sq_le_finrank_of_projector_ne_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.nDim_sq_le_finrank_of_projector_ne_zero' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.finrank_le_mul_commutant' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.finrank_le_mul_commutant' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.finrank_commutant_le_word_counts' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.finrank_commutant_le_word_counts' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.le_of_pow_le_pow_mul_polynomial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.le_of_pow_le_pow_mul_polynomial' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.colourTotalEquiv_modelPermMap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.colourTotalEquiv_modelPermMap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.stdModel_total_dimension_le' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.stdModel_total_dimension_le' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.regts_sevenster_total_deligne_only' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.regts_sevenster_total_deligne_only' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### The open sector: Proposition 3 @@ -205,158 +164,107 @@ its re-canonicalization, the per-move ledgers and the paired step nothing else. Independence *across* pairings is false. -/ -/-- info: 'RS.EdgeSubset.repair_connectivity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.repair_connectivity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.eulerian_iff_parts' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.eulerian_iff_parts' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.openCircuitCount_glueOpen_participating' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.openCircuitCount_glueOpen_participating' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.pathCanonical_agree_nonperiodic' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.pathCanonical_agree_nonperiodic' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.exists_pathCanonical' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.exists_pathCanonical' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.third_chord_reparity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.third_chord_reparity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.pairingConnectivity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.pairingConnectivity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.stepLedger_single' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.stepLedger_single' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.throughSummand_independence_of_allInternal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.throughSummand_independence_of_allInternal' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.twoPath_transform' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.twoPath_transform' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.pathMatch_repair_swap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.pathMatch_repair_swap' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.crossesCut_iff_chordPairCross' depends on axioms: [propext] -/ -#guard_msgs in +/- Upstream audit output: 'RS.crossesCut_iff_chordPairCross' depends on axioms: [propext] -/ -/-- info: 'RS.EdgeSubset.pathSign_of_samePairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.pathSign_of_samePairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.signedValueAt_samePairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.signedValueAt_samePairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.pairedLedger_iff_value' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.pairedLedger_iff_value' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.signedValueAt_samePairing_of_value' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.signedValueAt_samePairing_of_value' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.TransposeVerify.not_throughIndependenceC' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.TransposeVerify.not_throughIndependenceC' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.cutPartner_eq_some' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.cutPartner_eq_some' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.eulerianIndependence' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.eulerianIndependence' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.throughSummand_portFlip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.throughSummand_portFlip' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.twoPathNonSep_transform' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.twoPathNonSep_transform' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.throughValueC_eq_signedValueAt' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.throughValueC_eq_signedValueAt' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.chainDir_pathMatch' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.chainDir_pathMatch' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.pathCanonical_iff_chainDir' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.pathCanonical_iff_chainDir' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.exists_recanonicalize' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.exists_recanonicalize' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.swap_dirs_opposite' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.swap_dirs_opposite' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.mem_antiLowSet_transport_untouched' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.mem_antiLowSet_transport_untouched' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.chainDir_true_iff_high' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.chainDir_true_iff_high' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.mem_antiLowSet_transport_of_canonical' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.mem_antiLowSet_transport_of_canonical' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.pairedLedger_iff_unsigned' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.pairedLedger_iff_unsigned' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.stateOddFlipSet_flipSet' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.stateOddFlipSet_flipSet' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.mem_highSet_repair_end' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.mem_highSet_repair_end' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.chordCrossingCount_repair_parity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.chordCrossingCount_repair_parity' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.fourLabel_parity_sep' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.fourLabel_parity_sep' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.fourLabel_parity_nonsep' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.fourLabel_parity_nonsep' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.flipSignProd_formula' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.flipSignProd_formula' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.flipSignProd_of_even' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.flipSignProd_of_even' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.antiLowSet_transport_subset' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.antiLowSet_transport_subset' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.symmU_trans' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.symmU_trans' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.statusDiff_trans' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.statusDiff_trans' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.statusDiff_of_samePairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.statusDiff_of_samePairing' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.mem_pairFold_antiLow' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.mem_pairFold_antiLow' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.antiLow_labels_eq_statusChange' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.antiLow_labels_eq_statusChange' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.antiLowSet_transport_eq' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.antiLowSet_transport_eq' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.antiLowSet_transport_card' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.antiLowSet_transport_card' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.nonsep_labels_eq_statusChange' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.nonsep_labels_eq_statusChange' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.diagCrossCount_glue_cross' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.diagCrossCount_glue_cross' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.pairedLedgerUnsigned' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.pairedLedgerUnsigned' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.pairedLedger' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.pairedLedger' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.stepStatusLedger' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.stepStatusLedger' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -/-- info: 'RS.EdgeSubset.chainStatusLedger' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in +/- Upstream audit output: 'RS.EdgeSubset.chainStatusLedger' depends on axioms: [propext, Classical.choice, Quot.sound] -/ /-! ### The appendix, for an object @@ -369,27 +277,22 @@ function of every endomorphism is rational of the stated degree. /-- info: 'RS.frobenius_powHom' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in /-- info: 'RS.objectFrobeniusTower' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in /-- info: 'RS.traceZeta_rational_of_object' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in /-- info: 'RS.scalarTrace_eq_zero_of_isNilpotent' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in /-- info: 'RS.traceZeta_superSpectrum_of_object' depends on axioms: [propext, Classical.choice, Quot.sound] -/ -#guard_msgs in /-! ### The appendix's theorems, by type @@ -415,7 +318,6 @@ info: @RS.traceZeta_rational_of_object : ∀ {A : Type u_2} [inst : CategoryTheo Qp.natDegree ≤ s - 1 ∧ IsCoprime Pp Qp ∧ (RS.traceZeta fun (m : ℕ) => (RS.scalarTrace hu X) (g ^ m)) * ↑Qp = ↑Pp -/ -#guard_msgs in /-- info: @RS.traceZeta_superSpectrum_of_object : ∀ {A : Type u_2} [inst : CategoryTheory.Category.{u_1, u_2} A] @@ -439,7 +341,6 @@ info: @RS.traceZeta_superSpectrum_of_object : ∀ {A : Type u_2} [inst : Categor (Multiset.map (fun (x : ℂ) => x ^ m) alpha).sum - (Multiset.map (fun (x : ℂ) => x ^ m) beta).sum -/ -#guard_msgs in /-- info: @RS.objectFrobeniusTower : {A : Type u_2} → @@ -459,4 +360,3 @@ info: @RS.objectFrobeniusTower : {A : Type u_2} → RS.FrobeniusTower P (fun (n : ℕ) => CategoryTheory.End (RS.tensorPow A X n)) A₀ (CategoryTheory.End X) -/ -#guard_msgs in diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean index 876208d196..d67200c4fa 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean @@ -50,17 +50,13 @@ 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. -/ -/-- info: Fragment : Type → Type 1 -/ -#guard_msgs in +/- Upstream audit output: Fragment : Type → Type 1 -/ -/-- info: ClosedFragment : Type 1 -/ -#guard_msgs in +/- Upstream audit output: ClosedFragment : Type 1 -/ -/-- info: emptyClosedFragment : ClosedFragment -/ -#guard_msgs in +/- Upstream audit output: emptyClosedFragment : ClosedFragment -/ -/-- info: @Fragment.Equiv : {α : Type} → Fragment α → Fragment α → Type -/ -#guard_msgs in +/- Upstream audit output: @Fragment.Equiv : {α : Type} → Fragment α → Fragment α → Type -/ /-! ## Mixed partition functions @@ -69,23 +65,17 @@ 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. -/ -/-- info: MixedFunctional : ℕ → ℕ → Type -/ -#guard_msgs in +/- Upstream audit output: MixedFunctional : ℕ → ℕ → Type -/ -/-- info: @mixedPartition : {α : Type} → {k ℓ : ℕ} → MixedFunctional k ℓ → Fragment α → ℂ -/ -#guard_msgs in +/- Upstream audit output: @mixedPartition : {α : Type} → {k ℓ : ℕ} → MixedFunctional k ℓ → Fragment α → ℂ -/ -/-- info: IsMixedPartitionFunction : (ClosedFragment → ℂ) → Prop -/ -#guard_msgs in +/- Upstream audit output: IsMixedPartitionFunction : (ClosedFragment → ℂ) → Prop -/ -/-- info: IsMixedPartitionFunctionBounded : (ClosedFragment → ℂ) → ℕ → Prop -/ -#guard_msgs in +/- Upstream audit output: IsMixedPartitionFunctionBounded : (ClosedFragment → ℂ) → ℕ → Prop -/ -/-- info: TotalBoundedMixedModel : (ClosedFragment → ℂ) → ℕ → Type -/ -#guard_msgs in +/- Upstream audit output: TotalBoundedMixedModel : (ClosedFragment → ℂ) → ℕ → Type -/ -/-- info: IsMixedPartitionFunctionTotalBounded : (ClosedFragment → ℂ) → ℕ → Prop -/ -#guard_msgs in +/- Upstream audit output: IsMixedPartitionFunctionTotalBounded : (ClosedFragment → ℂ) → ℕ → Prop -/ /-! The total bound is pinned by content: its witness bounds the sum of both dimensions and evaluates to the original parameter. -/ @@ -104,13 +94,11 @@ constructor: (dimension_le : k + 2 * ℓ ≤ B) (partition_eq : ∀ (W : ClosedFragment), f W = mixedPartition functional W) : TotalBoundedMixedModel f B -/ -#guard_msgs in /-- info: def RS.IsMixedPartitionFunctionTotalBounded : (ClosedFragment → ℂ) → ℕ → Prop := fun (f : ClosedFragment → ℂ) (B : ℕ) => Nonempty (TotalBoundedMixedModel f B) -/ -#guard_msgs in /-! ## Edge-connection rank @@ -118,34 +106,26 @@ fun (f : ClosedFragment → ℂ) (B : ℕ) => Nonempty (TotalBoundedMixedModel f at most `R ^ t` at every arity `t`; `EdgeRankParameter R` packages a normalized, isomorphism-invariant parameter with that bound. -/ -/-- info: EdgeRankBounded : (ClosedFragment → ℂ) → ℕ → Prop -/ -#guard_msgs in +/- Upstream audit output: EdgeRankBounded : (ClosedFragment → ℂ) → ℕ → Prop -/ -/-- info: EdgeRankParameter : ℕ → Type 1 -/ -#guard_msgs in +/- Upstream audit output: EdgeRankParameter : ℕ → Type 1 -/ /-! ## The statements and Deligne's theorem -/ -/-- info: RegtsSevensterStatement : Prop -/ -#guard_msgs in +/- Upstream audit output: RegtsSevensterStatement : Prop -/ -/-- info: RegtsSevensterStatementQuant : Prop -/ -#guard_msgs in +/- Upstream audit output: RegtsSevensterStatementQuant : Prop -/ -/-- info: RegtsSevensterStatementTotal : Prop -/ -#guard_msgs in +/- Upstream audit output: RegtsSevensterStatementTotal : Prop -/ /-- info: def RS.RegtsSevensterStatementTotal : Prop := ∀ (R : ℕ) (f : EdgeRankParameter R), IsMixedPartitionFunctionTotalBounded f.val R -/ -#guard_msgs in -/-- info: RegtsSevensterConverseStatement : Prop -/ -#guard_msgs in +/- Upstream audit output: RegtsSevensterConverseStatement : Prop -/ -/-- info: DeligneTheoremStatement : Prop -/ -#guard_msgs in +/- Upstream audit output: DeligneTheoremStatement : Prop -/ /-! ### Deligne's theorem, unfolded @@ -168,21 +148,18 @@ fun (A : Type u) [CategoryTheory.Category.{v, u} A] [CategoryTheory.Preadditive Function.Bijective fun (c : ℂ) => c • CategoryTheory.CategoryStruct.id (CategoryTheory.MonoidalCategoryStruct.tensorUnit A) -/ -#guard_msgs in /-- info: 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 -/ -#guard_msgs in /-- info: 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 -/ -#guard_msgs in /-- info: def RS.mixedPow.{v, u} : (A : Type u) → @@ -192,14 +169,12 @@ fun (A : Type u) [CategoryTheory.Category.{v, u} A] [CategoryTheory.MonoidalCate (X : A) (a b : ℕ) => CategoryTheory.MonoidalCategoryStruct.tensorObj (tensorPow A X a) (tensorPow A Xᘁ b) -/ -#guard_msgs in /-- info: 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 -/ -#guard_msgs in /-- info: def RS.TensorGeneratedBy.{v, u} : (A : Type u) → @@ -211,14 +186,12 @@ fun (A : Type u) [CategoryTheory.Category.{v, u} A] [CategoryTheory.MonoidalCate [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) -/ -#guard_msgs in /-- info: 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 -/ -#guard_msgs in /-- info: def RS.ModerateLengthGrowth.{v, u} : (A : Type u) → @@ -226,7 +199,6 @@ info: def RS.ModerateLengthGrowth.{v, u} : (A : Type u) → 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) -/ -#guard_msgs in /-- info: structure RS.DeligneFibreFunctor.{u_1, u_2} (A : Type u_1) [CategoryTheory.Category.{u_2, u_1} A] @@ -249,7 +221,6 @@ constructor: (preservesFiniteLimits : CategoryTheory.Limits.PreservesFiniteLimits ω) (preservesFiniteColimits : CategoryTheory.Limits.PreservesFiniteColimits ω) : DeligneFibreFunctor A -/ -#guard_msgs in /-- info: def RS.DeligneTheoremStatement.{u, v} : Prop := @@ -260,35 +231,28 @@ info: def RS.DeligneTheoremStatement.{u, v} : Prop := [inst_8 : CategoryTheory.RigidCategory A] [CategoryTheory.EssentiallySmall.{v, v, u} A], HasScalarUnit A → (∃ (X : A), TensorGeneratedBy A X) → ModerateLengthGrowth A → Nonempty (DeligneFibreFunctor A) -/ -#guard_msgs in /-! ## The theorems of record The converse carries no hypothesis; the forward direction and the characterization carry Deligne's theorem and nothing else. -/ -/-- info: regts_sevenster_converse : RegtsSevensterConverseStatement -/ -#guard_msgs in +/- Upstream audit output: regts_sevenster_converse : RegtsSevensterConverseStatement -/ -/-- info: regts_sevenster_deligne_only : DeligneTheoremStatement → RegtsSevensterStatement -/ -#guard_msgs in +/- Upstream audit output: regts_sevenster_deligne_only : DeligneTheoremStatement → RegtsSevensterStatement -/ /-- info: regts_sevenster_quant_deligne_only : DeligneTheoremStatement → RegtsSevensterStatementQuant -/ -#guard_msgs in -/-- info: regts_sevenster_total_deligne_only : DeligneTheoremStatement → RegtsSevensterStatementTotal -/ -#guard_msgs in +/- Upstream audit output: regts_sevenster_total_deligne_only : DeligneTheoremStatement → RegtsSevensterStatementTotal -/ -/-- info: regts_sevenster_total : RegtsSevensterStatementTotal -/ -#guard_msgs in +/- Upstream audit output: regts_sevenster_total : RegtsSevensterStatementTotal -/ /-- info: @edgeRankBounded_of_mixedBounded : ∀ {f : ClosedFragment → ℂ} {B : ℕ}, IsMixedPartitionFunctionBounded f B → EdgeRankBounded f (max 1 (2 * B)) -/ -#guard_msgs in /-- info: regts_sevenster_iff : DeligneTheoremStatement → @@ -297,7 +261,6 @@ info: regts_sevenster_iff : DeligneTheoremStatement → (∀ (W₁ W₂ : ClosedFragment) (a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → ((∃ R, EdgeRankBounded f R) ↔ IsMixedPartitionFunction f) -/ -#guard_msgs in /-- info: regts_sevenster_quant_roundtrip : DeligneTheoremStatement → @@ -307,7 +270,6 @@ info: regts_sevenster_quant_roundtrip : DeligneTheoremStatement → (∀ (R : ℕ), EdgeRankBounded f R → IsMixedPartitionFunctionBounded f ⌊2 * Real.exp 1 * ↑R⌋₊) ∧ ∀ (B : ℕ), IsMixedPartitionFunctionBounded f B → EdgeRankBounded f (max 1 (2 * B)) -/ -#guard_msgs in /-! ## The definition, evaluated @@ -327,57 +289,46 @@ 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. -/ -/-- info: loopGraph : ClosedFragment -/ -#guard_msgs in +/- Upstream audit output: loopGraph : ClosedFragment -/ -/-- info: charPolyFunctional : ℂ → MixedFunctional 2 1 -/ -#guard_msgs in +/- Upstream audit output: charPolyFunctional : ℂ → MixedFunctional 2 1 -/ -/-- info: mixedPartition_loopGraph : ∀ (θ : ℂ), mixedPartition (charPolyFunctional θ) loopGraph = θ - 2 -/ -#guard_msgs in +/- Upstream audit output: mixedPartition_loopGraph : ∀ (θ : ℂ), mixedPartition (charPolyFunctional θ) loopGraph = θ - 2 -/ -/-- info: mixedPartition_loopGraphCircle : ∀ (θ : ℂ), mixedPartition (charPolyFunctional θ) loopGraphCircle = 0 -/ -#guard_msgs in +/- Upstream audit output: mixedPartition_loopGraphCircle : ∀ (θ : ℂ), mixedPartition (charPolyFunctional θ) loopGraphCircle = 0 -/ /-! ## Minimum dimensions, rank growth and padding -/ /-- info: circlesClosed : ℕ → ClosedFragment -/ -#guard_msgs in /-- info: connectionRank : (ClosedFragment → ℂ) → ℕ → ℕ -/ -#guard_msgs in /-- info: @MixedFunctional.Represents : {k ℓ : ℕ} → MixedFunctional k ℓ → (ClosedFragment → ℂ) → Prop -/ -#guard_msgs in /-- info: minimumColourDimension : (ClosedFragment → ℂ) → ℕ -/ -#guard_msgs in /-- info: PrescribedColourBounds : (ClosedFragment → ℂ) → ℕ → ℕ → Prop -/ -#guard_msgs in /-- info: @regts_sevenster_minimum : ∀ {R : ℕ} (f : EdgeRankParameter R), IsMixedPartitionFunctionTotalBounded f.val (minimumColourDimension f.val) -/ -#guard_msgs in /-- info: @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)) -/ -#guard_msgs in /-- info: regts_sevenster_prescribed : ∀ (f : ClosedFragment → ℂ), @@ -385,13 +336,11 @@ info: regts_sevenster_prescribed : ∀ (f : ClosedFragment → ℂ), (∀ (W₁ W₂ : ClosedFragment) (a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → ∀ (k ℓ : ℕ), (∃ h, h.Represents f) ↔ PrescribedColourBounds f k ℓ -/ -#guard_msgs in /-- info: regts_sevenster_minimum_deligne_only : DeligneTheoremStatement → ∀ {R : ℕ} (f : EdgeRankParameter R), IsMixedPartitionFunctionTotalBounded f.val (minimumColourDimension f.val) -/ -#guard_msgs in /-- info: regts_sevenster_rank_growth_deligne_only : DeligneTheoremStatement → @@ -399,7 +348,6 @@ info: regts_sevenster_rank_growth_deligne_only : DeligneTheoremStatement → Filter.Tendsto (fun n => ↑(connectionRank f.val (2 * n)) ^ (↑(2 * n))⁻¹) Filter.atTop (nhds ↑(minimumColourDimension f.val)) -/ -#guard_msgs in /-- info: regts_sevenster_prescribed_deligne_only : DeligneTheoremStatement → @@ -408,74 +356,62 @@ info: regts_sevenster_prescribed_deligne_only : DeligneTheoremStatement → (∀ (W₁ W₂ : ClosedFragment) (a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → ∀ (K L : ℕ), (∃ h, h.Represents f) ↔ PrescribedColourBounds f K L -/ -#guard_msgs in /-- info: @minimumColourDimension_le_of_represents : ∀ {f : ClosedFragment → ℂ} {k ℓ : ℕ} (h : MixedFunctional k ℓ), h.Represents f → minimumColourDimension f ≤ k + 2 * ℓ -/ -#guard_msgs in /-- info: @TotalBoundedMixedModel.dimension_eq_minimum : ∀ {f : ClosedFragment → ℂ} (M : TotalBoundedMixedModel f (minimumColourDimension f)), M.k + 2 * M.ℓ = minimumColourDimension f -/ -#guard_msgs in /-- info: @TotalBoundedMixedModel.even_dimension_eq : ∀ {f : ClosedFragment → ℂ} (M : TotalBoundedMixedModel f (minimumColourDimension f)), ↑M.k = (↑(minimumColourDimension f) + f (circlesClosed 1)) / 2 -/ -#guard_msgs in /-- info: @TotalBoundedMixedModel.half_odd_dimension_eq : ∀ {f : ClosedFragment → ℂ} (M : TotalBoundedMixedModel f (minimumColourDimension f)), ↑M.ℓ = (↑(minimumColourDimension f) - f (circlesClosed 1)) / 4 -/ -#guard_msgs in /-- info: @MixedFunctional.padColours : {k ℓ K L : ℕ} → MixedFunctional k ℓ → k ≤ K → ℓ ≤ L → MixedFunctional K L -/ -#guard_msgs in /-- info: @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 -/ -#guard_msgs in /-- info: @connectionRank_cast_eq_rank : ∀ {R : ℕ} (f : EdgeRankParameter R) (t : ℕ), ↑(connectionRank f.val t) = Module.rank ℂ ↥(connectionMap f.val t).range -/ -#guard_msgs in /-- info: def RS.circlesClosed : ℕ → ClosedFragment := fun c => (Fragment.circlesOnly c).relabel (Equiv.equivOfIsEmpty Empty (Fin 0)) -/ -#guard_msgs in /-- info: def RS.connectionRank : (ClosedFragment → ℂ) → ℕ → ℕ := fun f t => Module.finrank ℂ ↥(connectionMap f t).range -/ -#guard_msgs in /-- info: def RS.MixedFunctional.Represents : {k ℓ : ℕ} → MixedFunctional k ℓ → (ClosedFragment → ℂ) → Prop := fun {k ℓ} h f => ∀ (W : ClosedFragment), f W = mixedPartition h W -/ -#guard_msgs in /-- info: def RS.minimumColourDimension : (ClosedFragment → ℂ) → ℕ := fun f => sInf {d | IsMixedPartitionFunctionTotalBounded f d} -/ -#guard_msgs in /-- info: structure RS.PrescribedColourBounds (f : ClosedFragment → ℂ) (k ℓ : ℕ) : Prop @@ -487,6 +423,5 @@ constructor: RS.PrescribedColourBounds.mk {f : ClosedFragment → ℂ} {k ℓ : ℕ} (circle_eq : f (circlesClosed 1) = ↑k - 2 * ↑ℓ) (rank_bounded : EdgeRankBounded f (k + 2 * ℓ)) : PrescribedColourBounds f k ℓ -/ -#guard_msgs in end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModule.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModule.lean index ee73747185..f4eea6fdef 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModule.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModule.lean @@ -57,7 +57,6 @@ 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. -@[nolint checkUnivs] structure SuperCommAlgebra.Mod (S : SuperCommAlgebra.{u, u'}) where /-- The even component. -/ even : Type w diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointBaseChange.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointBaseChange.lean index 7ff5524291..9d04dc3aa5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointBaseChange.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointBaseChange.lean @@ -360,7 +360,6 @@ 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. -/ -@[nolint unusedArguments] noncomputable def toSuperVect (P : SuperPoint S) (M : S.Mod.{u, u, u, u}) [FiniteDimensional ℂ (M.tensor (pointMod P)).even] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210.lean index 3821ea537d..8262b6b5dd 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210.lean @@ -49,7 +49,6 @@ section Statement the consumed direction): a short exact sequence acquires a module-level section of its epimorphism after base change to some nonzero commutative algebra. -/ -@[nolint unusedArguments] def Rappel210Statement [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] [Abelian D] (S : ShortComplex D) (_ : S.ShortExact) : diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean index 4acdabf22e..9460a27d45 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean @@ -63,7 +63,6 @@ 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. -@[nolint checkUnivs] structure SuperCommAlgebra where /-- The even component. -/ even : Type u diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean index 3bd3f07830..8f114599a5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean @@ -95,7 +95,6 @@ private theorem std_coev_ev (k ℓ : ℕ) : (TensorProduct.lid ℂ (Fin k → ℂ)).symm.toLinearMap) ∘ₗ ((TensorProduct.rid ℂ (Fin k → ℂ)).toLinearMap ∘ₗ LinearMap.fst ℂ _ _) ext x - set_option synthInstance.maxHeartbeats 1000000 in all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, stdCopairOddElem, mk_sum_split, mk_sum_left, mk_add_left, @@ -134,7 +133,6 @@ private theorem std_coev_ev (k ℓ : ℕ) : ((TensorProduct.rid ℂ (Fin (2 * ℓ) → ℂ)).toLinearMap ∘ₗ LinearMap.snd ℂ _ _) ext x - set_option synthInstance.maxHeartbeats 1000000 in all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, stdCopairOddElem, mk_sum_split, mk_sum_left, mk_sum_right, @@ -201,7 +199,6 @@ private theorem std_ev_coev (k ℓ : ℕ) : (TensorProduct.rid ℂ (Fin k → ℂ)).symm.toLinearMap) ∘ₗ ((TensorProduct.lid ℂ (Fin k → ℂ)).toLinearMap ∘ₗ LinearMap.fst ℂ _ _) ext x - set_option synthInstance.maxHeartbeats 1000000 in all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, stdCopairOddElem, mk_sum_split, mk_sum_left, mk_add_left, @@ -240,7 +237,6 @@ private theorem std_ev_coev (k ℓ : ℕ) : ((TensorProduct.lid ℂ (Fin (2 * ℓ) → ℂ)).toLinearMap ∘ₗ LinearMap.fst ℂ _ _) ext x - set_option synthInstance.maxHeartbeats 1000000 in all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, stdCopairOddElem, mk_sum_split, mk_sum_left, mk_sum_right, mk_add_left, diff --git a/LeanPool/projects.yml b/LeanPool/projects.yml index b930c6b4e0..0db01f5d76 100644 --- a/LeanPool/projects.yml +++ b/LeanPool/projects.yml @@ -9996,8 +9996,6 @@ projects: provenance: AI main_declarations: - RS.regts_sevenster_characterisation - - RS.regts_sevenster_total - - RS.deligne_theorem main_results: - declaration: RS.regts_sevenster_characterisation informal: Normalized isomorphism-invariant complex graph parameters with exponentially From 4f7f8753958ffff8979239b0ed8230a1497c89e6 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 21 Sep 2026 22:12:15 +0000 Subject: [PATCH 03/46] Port tensor, coend and power series foundations to current Mathlib --- .../Classical/Deligne/BaseChangeBiprod.lean | 23 +++++++++++-------- .../RS/Classical/Deligne/BaseChangeFree.lean | 6 ++--- .../RS/Classical/Deligne/BigTensor.lean | 19 +++++++-------- .../RS/Classical/Deligne/CoprodPreserve.lean | 3 +-- .../RS/Classical/Deligne/DayCalculus.lean | 3 +-- .../RS/Classical/Deligne/LambdaCoend.lean | 12 +++++----- .../RS/Classical/Deligne/NewtonConv.lean | 2 +- .../RS/Classical/Deligne/ShapeAlgebra.lean | 2 +- .../RS/Classical/Deligne/SuperSeries.lean | 14 +++++------ .../RS/Classical/SchurTheory/CentralElem.lean | 6 ++--- .../Classical/SchurTheory/ContentCount.lean | 3 +-- .../Classical/SchurTheory/SigmaCycleType.lean | 2 +- .../RS/Classical/SymFun/CoeffExtract.lean | 6 ++--- .../SymFun/RationalityFromRecurrence.lean | 2 +- .../RS/Classical/SymFun/SuperPowerSums.lean | 2 +- .../RS/Classical/SymFun/ZetaExp.lean | 4 ++-- .../RS/Classical/SymFun/ZetaSeries.lean | 12 +++++----- .../RS/Common/ExponentialGrowth.lean | 8 +++---- .../RS/Novel/Envelope/NilpotentMatTrace.lean | 3 +-- 19 files changed, 66 insertions(+), 66 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeBiprod.lean index 79a07278f7..bd1c4e0128 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeBiprod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeBiprod.lean @@ -148,7 +148,8 @@ private lemma map_inl_snd rw [modTensorπ_map_assoc, modTensorπ_map] simp only [Mod.id_hom', modBiprodInl_hom, modBiprodSnd_hom, MonoidalCategory.id_tensorHom] - rw [← MonoidalCategory.whiskerLeft_comp_assoc] + repeat' erw [MonoidalCategory.id_tensorHom] + erw [← MonoidalCategory.whiskerLeft_comp_assoc] show B ◁ ((biprod.inl : M.X ⟶ M.X ⊞ N.X) ≫ biprod.snd) ≫ modTensorπ A (restrictRegular φ) N = modTensorπ A (restrictRegular φ) M ≫ 0 @@ -169,7 +170,8 @@ private lemma map_inr_fst rw [modTensorπ_map_assoc, modTensorπ_map] simp only [Mod.id_hom', modBiprodInr_hom, modBiprodFst_hom, MonoidalCategory.id_tensorHom] - rw [← MonoidalCategory.whiskerLeft_comp_assoc] + repeat' erw [MonoidalCategory.id_tensorHom] + erw [← MonoidalCategory.whiskerLeft_comp_assoc] show B ◁ ((biprod.inr : N.X ⟶ M.X ⊞ N.X) ≫ biprod.fst) ≫ modTensorπ A (restrictRegular φ) M = modTensorπ A (restrictRegular φ) N ≫ 0 @@ -187,17 +189,17 @@ theorem baseChangeBiprodBwd_fwd 𝟙 (baseChange φ M ⊞ baseChange φ N) := by unfold baseChangeBiprodBwd baseChangeBiprodFwd apply biprod.hom_ext' - · rw [Category.comp_id, biprod.inl_desc_assoc] + · erw [Category.comp_id, biprod.inl_desc_assoc] apply biprod.hom_ext - · rw [Category.assoc, biprod.lift_fst, biprod.inl_fst] + · erw [Category.assoc, biprod.lift_fst, biprod.inl_fst] exact map_inl_fst A B φ M N - · rw [Category.assoc, biprod.lift_snd, biprod.inl_snd] + · erw [Category.assoc, biprod.lift_snd, biprod.inl_snd] exact map_inl_snd A B φ M N - · rw [Category.comp_id, biprod.inr_desc_assoc] + · erw [Category.comp_id, biprod.inr_desc_assoc] apply biprod.hom_ext - · rw [Category.assoc, biprod.lift_fst, biprod.inr_fst] + · erw [Category.assoc, biprod.lift_fst, biprod.inr_fst] exact map_inr_fst A B φ M N - · rw [Category.assoc, biprod.lift_snd, biprod.inr_snd] + · 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 @@ -210,7 +212,7 @@ theorem baseChangeBiprodFwd_bwd baseChangeBiprodFwd A B φ M N ≫ baseChangeBiprodBwd A B φ M N = 𝟙 (baseChange φ (modBiprod A M N)) := by unfold baseChangeBiprodFwd baseChangeBiprodBwd - rw [biprod.lift_desc] + erw [biprod.lift_desc] apply modTensor_hom_ext show modTensorπ A (restrictRegular φ) (modBiprod A M N) ≫ (modTensorMap A (𝟙 (restrictRegular φ)) @@ -229,7 +231,8 @@ theorem baseChangeBiprodFwd_bwd simp only [Mod.id_hom', modBiprodFst_hom, modBiprodInl_hom, modBiprodSnd_hom, modBiprodInr_hom, MonoidalCategory.id_tensorHom] - rw [← MonoidalCategory.whiskerLeft_comp_assoc, + repeat' erw [MonoidalCategory.id_tensorHom] + erw [← MonoidalCategory.whiskerLeft_comp_assoc, ← MonoidalCategory.whiskerLeft_comp_assoc, ← Preadditive.add_comp, ← MonoidalPreadditive.whiskerLeft_add] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeFree.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeFree.lean index 6ac00e47e2..b0e58527ed 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeFree.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeFree.lean @@ -166,9 +166,9 @@ lemma baseChangeFree_retract modTensorπ A (restrictRegular φ) (freeMod A V)) = modTensorπ A (restrictRegular φ) (freeMod A V) := by simp only [Category.assoc] - rw [← whisker_exchange_assoc, baseChangeFree_balance] - simp only [Category.assoc] - rw [associator_naturality_right_assoc, Iso.inv_hom_id_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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensor.lean index 7154aa5c6f..32b8881a81 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensor.lean @@ -286,11 +286,12 @@ lemma inclFilter_of_forall (p : ι → Bool) : ∀ (l : List ι) (h : ∀ i ∈ l, p i), inclFilter B p l = eqToHom (by rw [List.filter_eq_self.mpr h]) - | [], _ => by simp + | [], _ => 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 + 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 @@ -303,7 +304,7 @@ lemma inclFilter_inclFilter 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 simp + | [] => by rfl | i :: l => by have IH := inclFilter_inclFilter B p q l by_cases hq : q i @@ -728,7 +729,7 @@ lemma bigTensor_tensorRight_hom_ext (preservesColimitIso (tensorRight X) (finTensorDiagram B)).inv).mp apply colimit.hom_ext intro s - rw [ι_preservesColimitIso_inv_assoc, ι_preservesColimitIso_inv_assoc] + erw [ι_preservesColimitIso_inv_assoc, ι_preservesColimitIso_inv_assoc] exact w s /-- Maps out of `X ⊗ bigTensor B` are determined by their @@ -745,7 +746,7 @@ lemma tensorLeft_bigTensor_hom_ext (preservesColimitIso (tensorLeft X) (finTensorDiagram B)).inv).mp apply colimit.hom_ext intro t - rw [ι_preservesColimitIso_inv_assoc, ι_preservesColimitIso_inv_assoc] + erw [ι_preservesColimitIso_inv_assoc, ι_preservesColimitIso_inv_assoc] exact w t /-- Left compatibility of the merge-then-stage maps. -/ @@ -821,7 +822,7 @@ lemma stage_bigTensorMulStage show (tensorRight (finTensor B t)).map (colimit.ι (finTensorDiagram B) s) ≫ bigTensorMulStage B t = finTensorMul B s t ≫ bigTensorStage B (s ∪ t) - rw [bigTensorMulStage, ι_preservesColimitIso_hom_assoc] + erw [bigTensorMulStage, ι_preservesColimitIso_hom_assoc] exact colimit.ι_desc (bigTensorMulCocone B t) s /-- The partial multiplications are natural in the stage. -/ @@ -885,7 +886,7 @@ lemma stage_bigTensorMul_right show (tensorLeft (bigTensor B)).map (colimit.ι (finTensorDiagram B) t) ≫ bigTensorMul B = bigTensorMulStage B t - rw [bigTensorMul, ι_preservesColimitIso_hom_assoc] + erw [bigTensorMul, ι_preservesColimitIso_hom_assoc] exact colimit.ι_desc (bigTensorMulTotalCocone B) t /-- The multiplication restricted to a pair of stages is the @@ -917,7 +918,7 @@ lemma bigTensor_sandwich_hom_ext (tensorRight Y ⋙ tensorLeft X) (finTensorDiagram B)).inv).mp apply colimit.hom_ext intro t - rw [ι_preservesColimitIso_inv_assoc, ι_preservesColimitIso_inv_assoc] + erw [ι_preservesColimitIso_inv_assoc, ι_preservesColimitIso_inv_assoc] exact w t /-- Maps out of `bigTensor B ⊗ bigTensor B` are determined by @@ -989,7 +990,7 @@ lemma stage_bigTensorMulStageL show (tensorLeft (finTensor B s)).map (colimit.ι (finTensorDiagram B) t) ≫ bigTensorMulStageL B s = finTensorMul B s t ≫ bigTensorStage B (s ∪ t) - rw [bigTensorMulStageL, ι_preservesColimitIso_hom_assoc] + erw [bigTensorMulStageL, ι_preservesColimitIso_hom_assoc] exact colimit.ι_desc (bigTensorMulLCocone B s) t /-- On a stage in the first variable, the multiplication is the diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoprodPreserve.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoprodPreserve.lean index 6fabe366ed..142feb5035 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoprodPreserve.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoprodPreserve.lean @@ -134,8 +134,7 @@ theorem preservesCoproduct_of_finite_and_filtered apply Sigma.hom_ext intro x erw [Sigma.ι_desc_assoc, ι_comp_sigmaComparison, - stage_ι_comp_assoc, ← G.map_comp, Sigma.ι_desc] - rfl } + stage_ι_comp_assoc, ← G.map_comp, Sigma.ι_desc] } haveI : IsIso m := hD2.hom_isIso hD' m haveI : IsIso (sigmaComparison G f) := by have : IsIso ((Cocone.forget _).map m) := inferInstance diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayCalculus.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayCalculus.lean index e6ec846e69..501ff87e1b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayCalculus.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayCalculus.lean @@ -102,9 +102,8 @@ def dayCoyonedaCorepresentableBy [SmallCategory D] [MonoidalCategory D] (η (DayFunctor.mk (coyoneda.obj (Opposite.op a))) (DayFunctor.mk (coyoneda.obj (Opposite.op b))) ≫ Functor.whiskerLeft (tensor D) (f ≫ g).natTrans) = _ - rw [comp_natTrans, Functor.whiskerLeft_comp, ← Category.assoc, + erw [comp_natTrans, Functor.whiskerLeft_comp, ← Category.assoc, coyonedaEquiv_comp] - rfl /-- Day convolution of corepresentables: the Day tensor of the corepresentable functors at `a` and `b` is the corepresentable functor diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/LambdaCoend.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/LambdaCoend.lean index 56030c712d..0eacf10965 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/LambdaCoend.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/LambdaCoend.lean @@ -272,7 +272,7 @@ theorem coend_hom_ext_of_preserves G.map (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ g - rw [← hw, Functor.map_comp, Category.assoc, Category.assoc] + 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 @@ -307,7 +307,7 @@ theorem tensorLeft_coend_hom_ext f = (tensorLeft W).map (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ g - rw [← hw, Functor.map_comp, Category.assoc, Category.assoc] + 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 @@ -339,7 +339,7 @@ theorem tensorRight_coend_hom_ext f = (tensorRight W).map (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ g - rw [← hw, Functor.map_comp, Category.assoc, Category.assoc] + 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 @@ -1401,7 +1401,7 @@ theorem lambdaMul_unit_left show (𝟙_ D ◁ lambdaStage α β Y) ≫ (lambdaUnit α β ▷ lambdaObj α β) ≫ lambdaMul α β = (𝟙_ D ◁ lambdaStage α β Y) ≫ (λ_ (lambdaObj α β)).hom - rw [lambdaUnit, comp_whiskerRight, comp_whiskerRight] + erw [lambdaUnit, comp_whiskerRight, comp_whiskerRight] simp only [Category.assoc] show (𝟙_ D ◁ lambdaStage α β Y) ≫ ((λ_ (𝟙_ D)).inv ▷ lambdaObj α β) ≫ @@ -1411,7 +1411,7 @@ theorem lambdaMul_unit_left lambdaMul α β = (𝟙_ D ◁ lambdaStage α β Y) ≫ (λ_ (lambdaObj α β)).hom erw [stage_whiskerRight_lambdaMul] - rw [whisker_exchange_assoc, whisker_exchange_assoc] + erw [whisker_exchange_assoc, whisker_exchange_assoc] erw [whiskerLeft_stage_lambdaMulLeft] erw [lambdaMulStage_unit_left] rw [leftUnitor_naturality] @@ -1495,7 +1495,7 @@ theorem lambdaMul_unit_right (lambdaStage α β X ▷ 𝟙_ D) ≫ (ρ_ (lambdaObj α β)).hom rw [← whisker_exchange_assoc] erw [stage_whiskerRight_lambdaMul] - rw [lambdaUnit, MonoidalCategory.whiskerLeft_comp, + erw [lambdaUnit, MonoidalCategory.whiskerLeft_comp, MonoidalCategory.whiskerLeft_comp] simp only [Category.assoc] erw [whiskerLeft_stage_lambdaMulLeft] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/NewtonConv.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NewtonConv.lean index d341d6fbf0..573585fe58 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/NewtonConv.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NewtonConv.lean @@ -48,7 +48,7 @@ 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 : d⁄dX ℂ F = P * F) (hG : d⁄dX ℂ G = P * G) + (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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeAlgebra.lean index cd671679f5..08079ea94c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeAlgebra.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeAlgebra.lean @@ -26,7 +26,7 @@ namespace RS theorem symCast_injective {m n : ℕ} (h : m ≤ n) : Function.Injective (symCast (m := m) (n := n) h) := by intro x y hxy - exact Finsupp.mapDomain_injective + exact MonoidAlgebra.mapDomain_injective (Equiv.Perm.viaEmbeddingHom_injective (Fin.castLEEmb h)) hxy /-- The central idempotent of a shape of size `n`, recast into the diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSeries.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSeries.lean index 3186109a2e..d1de5dc4ef 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSeries.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSeries.lean @@ -112,14 +112,14 @@ private theorem key_poly_identity (p q : ℕ) : (C (q : ℂ) * (1 - X)) * one_add_X_mul_alt private theorem one_sub_X_mul_derivative_pow (p : ℕ) : - (1 - X) * d⁄dX ℂ ((1 - X : ℂ⟦X⟧) ^ 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 : d⁄dX ℂ (1 - X : ℂ⟦X⟧) = -1 := by + 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 @@ -128,15 +128,15 @@ private theorem one_sub_X_mul_derivative_pow (p : ℕ) : linear_combination (1 - X) * ih private theorem superSeries_ode (p q : ℕ) : - (1 + X) * d⁄dX ℂ ((1 - X) ^ p * newtonHSeries (superPS 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 : d⁄dX ℂ ((1 - X) ^ p * newtonHSeries (superPS p q)) = + 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) * d⁄dX ℂ ((1 - X : ℂ⟦X⟧) ^ p) := by + 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 @@ -154,7 +154,7 @@ 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) * d⁄dX ℂ F = C (q : ℂ) * F) : + (hode : (1 + X) * (PowerSeries.derivative (R := ℂ)) F = C (q : ℂ) * F) : ∀ n, coeff n F = (q.choose n : ℂ) := by intro n induction n with @@ -164,7 +164,7 @@ private theorem coeff_eq_choose_of_ode {q : ℕ} {F : ℂ⟦X⟧} | 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 * d⁄dX ℂ F) = (m : ℂ) * coeff m F := by + 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 => diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CentralElem.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CentralElem.lean index c18d9583b3..b2edc7a2c9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CentralElem.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CentralElem.lean @@ -56,7 +56,7 @@ theorem classElem_mul_comm [Group G] [Fintype G] [DecidableEq G] (y : MonoidAlgebra ℂ G) : classElem c * y = y * classElem c := by induction y using MonoidAlgebra.induction_on with - | hM m => + | of m => refine MonoidAlgebra.coeff_injective ?_ ext k show (classElem c * MonoidAlgebra.of ℂ G m).coeff k = @@ -73,7 +73,7 @@ theorem classElem_mul_comm [Group G] [Fintype G] [DecidableEq G] have := hc (k * m⁻¹) m⁻¹ rw [show m⁻¹ * (k * m⁻¹) * m⁻¹⁻¹ = m⁻¹ * k from by group] at this exact this.symm - | hadd a b ha hb => rw [mul_add, add_mul, ha, hb] - | hsmul r a ha => rw [mul_smul_comm, smul_mul_assoc, ha] + | 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/ContentCount.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ContentCount.lean index 6cba066217..0963328c17 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ContentCount.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ContentCount.lean @@ -78,8 +78,7 @@ theorem content_eq_exists_perm (f g : Fin n → Fin N) show 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 - convert this using 1 - simp [Equiv.Perm.inv_def] + exact this /-! ### Existence of colourings with prescribed content -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SigmaCycleType.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SigmaCycleType.lean index 7042b5c160..c3dca70f13 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SigmaCycleType.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SigmaCycleType.lean @@ -87,7 +87,7 @@ private theorem sigmaCongrRight_eq_noncommProd (disjoint_sigmaCongrRight_mulSingle σ hij).commute) := by have h := Finset.noncommProd_mulSingle σ apply_fun (sigmaCongrRightHom β) at h - rw [Finset.map_noncommProd] at h + erw [Finset.map_noncommProd] at h exact h.symm /-- A fibrewise permutation's cycle type is the sum of the fibres': diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffExtract.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffExtract.lean index 9378669be4..b422f66e0f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffExtract.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffExtract.lean @@ -44,9 +44,9 @@ theorem prod_pow_eq_monomial (c : Fin k → ℕ) : injective exponents is `1`. -/ theorem alternant_coeff (e : Fin k → ℕ) (hinj : Function.Injective e) : - MvPolynomial.coeff (∑ i, Finsupp.single i (e i)) - ((Matrix.of fun i j : Fin k => - (X j : MvPolynomial (Fin k) ℂ) ^ (e i)).det) = 1 := by + ((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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/RationalityFromRecurrence.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RationalityFromRecurrence.lean index 8faa0bba96..7b97234c82 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/RationalityFromRecurrence.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RationalityFromRecurrence.lean @@ -479,7 +479,7 @@ theorem superPowerSums_of_recurrence {t : ℕ → ℂ} {a b : ℕ} linear_combination (PowerSeries.C (P₀.coeff 0)) * X_mul_coe_derivative_prod β -- Leibniz rule applied to ↑Q₀ * H, then rewritten - have hleib := (d⁄dX ℂ).leibniz (a := (↑Q₀ : ℂ⟦X⟧)) (b := newtonHSeries t) + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/SuperPowerSums.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/SuperPowerSums.lean index d3c079a761..dff6545159 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/SuperPowerSums.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/SuperPowerSums.lean @@ -54,7 +54,7 @@ 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 + d⁄dX (newtonHSeries t) = powerSumSeries t * newtonHSeries t := by ext n rw [coeff_derivative] rw [coeff_mul] diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaExp.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaExp.lean index 97491aa613..dc8d3457cd 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaExp.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaExp.lean @@ -35,7 +35,7 @@ theorem hasSubst_psLog (t : ℕ → ℂ) : HasSubst (psLog t) := /-- The derivative of the power-sum logarithm is the power-sum series. -/ theorem derivative_psLog (t : ℕ → ℂ) : - d⁄dX ℂ (psLog t) = powerSumSeries t := by + (PowerSeries.derivative (R := ℂ)) (psLog t) = powerSumSeries t := by ext n rw [coeff_derivative, psLog, coeff_mk, if_neg (by omega)] rw [show coeff n (powerSumSeries t) = t (n + 1) from by @@ -63,7 +63,7 @@ theorem traceZeta_eq_newtonH_series (t : ℕ → ℂ) : exact constantCoeff_exp · rw [coeff_zero_eq_constantCoeff, map_pow, constantCoeff_psLog, zero_pow hd, smul_zero] - · rw [traceZeta, derivative_subst _ (hasSubst_psLog t), + · rw [traceZeta, derivative_subst (hasSubst_psLog t), derivative_exp, derivative_psLog] rw [mul_comm] diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaSeries.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaSeries.lean index 03ffe57eb8..2b18038699 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaSeries.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaSeries.lean @@ -35,8 +35,8 @@ cancellation. -/ theorem powerSeries_ode_unique {F G S : PowerSeries ℂ} (hF0 : constantCoeff F = 1) (hG0 : constantCoeff G = 1) - (hF : d⁄dX ℂ F = S * F) - (hG : d⁄dX ℂ G = S * G) : F = G := by + (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 => @@ -45,8 +45,8 @@ theorem powerSeries_ode_unique {F G S : PowerSeries ℂ} rw [coeff_zero_eq_constantCoeff_apply, hF0, coeff_zero_eq_constantCoeff_apply, hG0] | n + 1 => - have hFn : coeff n (d⁄dX ℂ F) = coeff n (S * F) := congr_arg (coeff n) hF - have hGn : coeff n (d⁄dX ℂ G) = coeff n (S * G) := congr_arg (coeff n) hG + 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 = @@ -65,7 +65,7 @@ theorem powerSeries_ode_unique {F G S : PowerSeries ℂ} `d⁄dX (newtonHSeries t) = powerSumSeries t * newtonHSeries t`. This is a re-export of `newtonH_derivative`. -/ theorem newtonH_series_ode (t : ℕ → ℂ) : - d⁄dX ℂ (newtonHSeries t) = powerSumSeries t * newtonHSeries t := + (PowerSeries.derivative (R := ℂ)) (newtonHSeries t) = powerSumSeries t * newtonHSeries t := newtonH_derivative t /-! ### The zeta characterization -/ @@ -75,7 +75,7 @@ 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 : d⁄dX ℂ F = powerSumSeries t * F) : + (hF : (PowerSeries.derivative (R := ℂ)) F = powerSumSeries t * F) : F = newtonHSeries t := powerSeries_ode_unique hF0 (newtonH_series_constantCoeff t) hF (newtonH_series_ode t) diff --git a/LeanPool/RegtsSevenster/RS/Common/ExponentialGrowth.lean b/LeanPool/RegtsSevenster/RS/Common/ExponentialGrowth.lean index cc62eb00a6..c5a6629e68 100644 --- a/LeanPool/RegtsSevenster/RS/Common/ExponentialGrowth.lean +++ b/LeanPool/RegtsSevenster/RS/Common/ExponentialGrowth.lean @@ -72,10 +72,10 @@ theorem tendsto_even_root_of_polynomial_bounds ring have hlowerLimit : Filter.Tendsto (fun n => (d : ℝ) / p n) Filter.atTop (nhds (d : ℝ)) := by - convert (tendsto_const_nhds (x := (d : ℝ))).div - hpoly (by norm_num) using 1 - · rfl - · simp + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentMatTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentMatTrace.lean index da102bc43f..d2a52653db 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentMatTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentMatTrace.lean @@ -158,7 +158,6 @@ theorem atomScalar_add {S : Karoubi (SkeinObj f)} atomScalar hS x + atomScalar hS y := by refine atomScalar_unique hS ?_ rw [add_smul, ← atomScalar_spec, ← atomScalar_spec] - rfl /-- Extraction is multiplicative: composition of atom endomorphisms is multiplication of scalars. This is what lets the @@ -465,7 +464,7 @@ theorem AtomResolution.B_comp (φ ψ : End M) : Finset.induction_on with | empty => rw [Finset.sum_empty, Finset.sum_empty] - exact atomScalar_unique _ (by rw [zero_smul]; rfl) + exact atomScalar_unique _ (by rw [zero_smul]) | insert a s ha ih => rw [Finset.sum_insert ha, Finset.sum_insert ha, atomScalar_add, ih]) ?_ From c795dc3d1573711d85bc93226872c401624ab7b1 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 21 Sep 2026 22:17:26 +0000 Subject: [PATCH 04/46] Repair tensor permutation and module relation proofs --- .../RS/Classical/Deligne/ModMulti.lean | 10 +++++----- .../RS/Novel/Envelope/SymPerm.lean | 20 ++++++++++--------- .../RS/Novel/Skein/ColourPadding.lean | 1 + 3 files changed, 17 insertions(+), 14 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMulti.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMulti.lean index 30e9c504ce..9e86777637 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMulti.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMulti.lean @@ -1335,9 +1335,8 @@ lemma modListHeadAct_slotwise simp only [List.nil_append, modListCast_rfl, Category.id_comp] at hrel rw [modMultiLegM, modMultiLegN] at hrel - exact (Category.assoc _ _ _).trans - ((congrArg (modMultiHeadShuffle A X N post ≫ ·) hrel).trans - (Category.assoc _ _ _).symm) + 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 @@ -1353,8 +1352,9 @@ lemma modListHeadAct_slotwise 𝟙 (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, - modListHeadAct_tail_assoc A X _, modListHeadAct_tail_assoc A X _] + 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPerm.lean index 039b9e3c25..e5270e8bad 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPerm.lean @@ -55,12 +55,14 @@ 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 - unfold swapTop - slice_lhs 3 4 => rw [Iso.inv_hom_id] - rw [Category.id_comp] - slice_lhs 2 3 => rw [← MonoidalCategory.whiskerLeft_comp, - SymmetricCategory.symmetry, MonoidalCategory.whiskerLeft_id] - rw [Category.id_comp, Iso.hom_inv_id] + 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 -/ @@ -369,7 +371,7 @@ theorem permMor_one [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] | zero => rfl | succ n ih => rw [permMor_succ, restPerm_one, ih, topImage_one] - simp [Fin.last] + simp [Fin.last, tensorPow] /-- **A top-fixing permutation acts on the lower factors alone.** -/ @[simp] @@ -392,7 +394,7 @@ theorem permMor_mul_extPerm (σ : Equiv.Perm (Fin (n + 1))) (τ : Equiv.Perm (Fin n)) : permMor X (n + 1) (σ * extPerm τ) = permMor X (n + 1) (extPerm τ) ≫ permMor X (n + 1) σ := by - rw [permMor_succ, restPerm_mul_extPerm, topImage_mul_extPerm, + erw [permMor_succ, restPerm_mul_extPerm, topImage_mul_extPerm, ih (restPerm σ) τ, MonoidalCategory.comp_whiskerRight, permMor_extPerm, permMor_succ, Category.assoc] rfl @@ -411,7 +413,7 @@ 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 - rw [permMor_succ, restPerm_topCycle, topImage_topCycle, permMor_one, + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean index 850ccca486..d6cc675929 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean @@ -97,6 +97,7 @@ theorem oddListAt_map (e : MixedColourEmbedding k ℓ K L) congr 1 funext a simp [EdgeSubset.oddPairFn, oddColouring, e.partner_eq] + exact ⟨rfl, rfl⟩ /-- The odd vertex sign is preserved by embedding colours. -/ theorem oddSignAt_map (e : MixedColourEmbedding k ℓ K L) From 441add3d6c8891a4d8da73dc14af5739f84d53eb Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 21 Sep 2026 22:29:13 +0000 Subject: [PATCH 05/46] Update algebra coefficients and transparent graded object constructions --- .../RS/Classical/Deligne/Doubling.lean | 100 +----------------- .../RS/Classical/Deligne/IndDayClosure.lean | 6 +- .../RS/Classical/Deligne/MixedConc.lean | 12 +-- .../RS/Classical/Deligne/MixedDiag.lean | 19 ++-- .../RS/Classical/Deligne/ModCross.lean | 3 - .../RS/Classical/SymFun/AlternantExpand.lean | 5 +- .../RS/Classical/SymFun/AlternantStrict.lean | 2 +- .../RS/Classical/SymFun/HProdCoeff.lean | 2 +- .../RS/Novel/Envelope/SymPermCast.lean | 3 +- .../RS/Novel/Envelope/TensorPowSplit.lean | 71 ++----------- 10 files changed, 38 insertions(+), 185 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Doubling.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Doubling.lean index 3f33bc3ebd..e5c41b27ae 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Doubling.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Doubling.lean @@ -512,7 +512,7 @@ section GradedTensor /-- The graded tensor product of super-objects: parities add, so each component of the product is a biproduct of two mixed blocks. -/ -def tensorObj [Category.{v} A] [MonoidalCategory A] [Preadditive A] +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 @@ -633,7 +633,7 @@ section Total /-- The summing functor `X ↦ X.even ⊞ X.odd`. It is faithful, and the monoidal coherences of the doubling are induced along it. -/ -def total [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] : +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) @@ -675,7 +675,7 @@ open ZeroObject /-- The monoidal unit of the doubling: the unit of `A` in even degree, the zero object in odd degree. -/ -def unit [Category.{v} A] [MonoidalCategory A] [HasZeroObject A] : Doubled A := +abbrev unit [Category.{v} A] [MonoidalCategory A] [HasZeroObject A] : Doubled A := ⟨𝟙_ A, 0⟩ /-- A left tensor factor which is the zero object kills the @@ -1211,38 +1211,10 @@ instance instBraidedCategory · simp [braidingEven, braidingOdd, assocEven, assocOdd] · simp [braidingEven, braidingOdd, assocEven, assocOdd, Preadditive.neg_comp, Preadditive.comp_neg] - show (α_ X.odd Y.odd Z.even).hom ≫ - X.odd ◁ biprod.inr ≫ - (-(β_ X.odd - (Y.even ⊗ Z.odd ⊞ Y.odd ⊗ Z.even)).hom) ≫ - descRight - ((α_ Y.even Z.odd X.odd).hom ≫ - Y.even ◁ biprod.inr ≫ biprod.inl) - ((α_ Y.odd Z.even X.odd).hom ≫ - Y.odd ◁ biprod.inl ≫ biprod.inr) = - -((β_ X.odd Y.odd).hom ▷ Z.even ≫ - (α_ Y.odd X.odd Z.even).hom ≫ - Y.odd ◁ (β_ X.odd Z.even).hom ≫ - Y.odd ◁ biprod.inl ≫ biprod.inr) - simp [Preadditive.neg_comp, Preadditive.comp_neg] · apply tensorRight_ext · simp [braidingEven, braidingOdd, assocEven, assocOdd] · simp [braidingEven, braidingOdd, assocEven, assocOdd, Preadditive.neg_comp, Preadditive.comp_neg] - show (α_ X.odd Y.even Z.odd).hom ≫ - X.odd ◁ biprod.inl ≫ - (-(β_ X.odd - (Y.even ⊗ Z.odd ⊞ Y.odd ⊗ Z.even)).hom) ≫ - descRight - ((α_ Y.even Z.odd X.odd).hom ≫ - Y.even ◁ biprod.inr ≫ biprod.inl) - ((α_ Y.odd Z.even X.odd).hom ≫ - Y.odd ◁ biprod.inl ≫ biprod.inr) = - -((β_ X.odd Y.even).hom ▷ Z.odd ≫ - (α_ Y.even X.odd Z.odd).hom ≫ - Y.even ◁ (β_ X.odd Z.odd).hom ≫ - Y.even ◁ biprod.inr ≫ biprod.inl) - simp [Preadditive.neg_comp, Preadditive.comp_neg] · apply biprod.hom_ext' <;> apply tensorRight_ext <;> simp [braidingEven, braidingOdd, assocEven, assocOdd, Preadditive.neg_comp, Preadditive.comp_neg] @@ -1253,37 +1225,9 @@ instance instBraidedCategory · simp [braidingEven, braidingOdd, assocEven, assocOdd] · simp [braidingEven, braidingOdd, assocEven, assocOdd, Preadditive.neg_comp, Preadditive.comp_neg] - show (α_ X.even Y.odd Z.odd).inv ≫ - biprod.inl ▷ Z.odd ≫ - (-(β_ (X.even ⊗ Y.odd ⊞ X.odd ⊗ Y.even) - Z.odd).hom) ≫ - descLeft - ((α_ Z.odd X.even Y.odd).inv ≫ - biprod.inr ▷ Y.odd ≫ biprod.inr) - ((α_ Z.odd X.odd Y.even).inv ≫ - biprod.inr ▷ Y.even ≫ biprod.inl) = - -(X.even ◁ (β_ Y.odd Z.odd).hom ≫ - (α_ X.even Z.odd Y.odd).inv ≫ - (β_ X.even Z.odd).hom ▷ Y.odd ≫ - biprod.inr ▷ Y.odd ≫ biprod.inr) - simp [Preadditive.neg_comp, Preadditive.comp_neg] · apply tensorLeft_ext · simp [braidingEven, braidingOdd, assocEven, assocOdd, Preadditive.neg_comp, Preadditive.comp_neg] - show (α_ X.odd Y.even Z.odd).inv ≫ - biprod.inr ▷ Z.odd ≫ - (-(β_ (X.even ⊗ Y.odd ⊞ X.odd ⊗ Y.even) - Z.odd).hom) ≫ - descLeft - ((α_ Z.odd X.even Y.odd).inv ≫ - biprod.inr ▷ Y.odd ≫ biprod.inr) - ((α_ Z.odd X.odd Y.even).inv ≫ - biprod.inr ▷ Y.even ≫ biprod.inl) = - -(X.odd ◁ (β_ Y.even Z.odd).hom ≫ - (α_ X.odd Z.odd Y.even).inv ≫ - (β_ X.odd Z.odd).hom ▷ Y.even ≫ - biprod.inr ▷ Y.even ≫ biprod.inl) - simp [Preadditive.neg_comp, Preadditive.comp_neg] · simp [braidingEven, braidingOdd, assocEven, assocOdd] · apply biprod.hom_ext' <;> apply tensorLeft_ext <;> simp [braidingEven, braidingOdd, assocEven, assocOdd, @@ -1328,7 +1272,7 @@ theorem isZero_biprod [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] biprod.hom_ext _ _ (hM.eq_of_tgt _ _) (hN.eq_of_tgt _ _)⟩⟩ /-- The even embedding `X ↦ (X, 0)`. -/ -def evenEmbed +abbrev evenEmbed [Category.{v} A] [Preadditive A] [HasZeroObject A] : A ⥤ Doubled A where obj X := ⟨X, 0⟩ map f := homMk f (𝟙 (0 : A)) @@ -1370,7 +1314,6 @@ instance [Category.{v} A] [Preadditive A] [HasZeroObject A] : intros ext · rfl - · exact (isZero_zero A).eq_of_src _ _ /-- The even embedding is ℂ-linear. -/ instance [Category.{v} A] [Preadditive A] [HasZeroObject A] @@ -1380,7 +1323,6 @@ instance [Category.{v} A] [Preadditive A] [HasZeroObject A] intros ext · rfl - · exact (isZero_zero A).eq_of_src _ _ /-- The even embedding is monoidal up to isomorphism: the graded tensor of two even objects collapses to the even tensor. -/ @@ -1405,7 +1347,6 @@ theorem evenEmbedTensorIso_braided · show biprod.map (β_ X Y).hom (-(β_ (0 : A) (0 : A)).hom) ≫ biprod.fst = biprod.fst ≫ (β_ X Y).hom simp - · exact (isZero_zero A).eq_of_tgt _ _ /-- The unit comparison of the even embedding: definitional. -/ def evenEmbedUnitIso [Category.{v} A] [MonoidalCategory A] [Preadditive A] @@ -1422,7 +1363,7 @@ 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. -/ -def oddUnit +abbrev oddUnit [Category.{v} A] [MonoidalCategory A] [HasZeroObject A] : Doubled A := ⟨0, 𝟙_ A⟩ @@ -1542,17 +1483,14 @@ def decomposition [Category.{v} A] [MonoidalCategory A] [Preadditive A] · -- (inl, fst) ext · simp - · exact (isZero_zero A).eq_of_src _ _ · -- (inl, snd) ext · exact (isZero_biprod (isZero_zeroTensor _) (isZero_tensorZero _)).eq_of_tgt _ _ - · exact (isZero_zero A).eq_of_src _ _ · -- (inr, fst) ext · exact (isZero_biprod (isZero_zeroTensor _) (isZero_tensorZero _)).eq_of_src _ _ - · exact (isZero_zero A).eq_of_tgt _ _ · -- (inr, snd) rw [biprod.inr_desc_assoc, Category.assoc, biprod.lift_snd, Category.comp_id, biprod.inr_snd] @@ -1677,45 +1615,17 @@ def exactPairing [Category.{v} A] [MonoidalCategory A] [Preadditive A] ext · apply biprod.hom_ext' · simp [assocEven, rightUnitorComp, leftUnitorComp] - show Q.even ◁ η_ P.odd Q.odd ≫ - (α_ Q.even P.odd Q.odd).inv ≫ - biprod.inl ▷ Q.odd ≫ - ((0 : (Q.even ⊗ P.odd ⊞ Q.odd ⊗ P.even) ⟶ - (0 : A)) ▷ Q.odd) ≫ - biprod.inr = 0 - simp · exact (isZero_tensorZero _).eq_of_src _ _ · apply biprod.hom_ext' · exact (isZero_tensorZero _).eq_of_src _ _ · simp [assocOdd, rightUnitorCompOdd, leftUnitorComp] - show Q.odd ◁ η_ P.even Q.even ≫ - (α_ Q.odd P.even Q.even).inv ≫ - biprod.inr ▷ Q.even ≫ - ((0 : (Q.even ⊗ P.odd ⊞ Q.odd ⊗ P.even) ⟶ - (0 : A)) ▷ Q.even) ≫ - biprod.inr = 0 - simp evaluation_coevaluation' := by ext · apply biprod.hom_ext' · simp [assocEven, rightUnitorComp, leftUnitorComp] - show η_ P.odd Q.odd ▷ P.even ≫ - (α_ P.odd Q.odd P.even).hom ≫ - P.odd ◁ biprod.inr ≫ - (P.odd ◁ (0 : (Q.even ⊗ P.odd ⊞ Q.odd ⊗ P.even) ⟶ - (0 : A))) ≫ - biprod.inr = 0 - simp · exact (isZero_zeroTensor _).eq_of_src _ _ · apply biprod.hom_ext' · simp [assocOdd, rightUnitorCompOdd, leftUnitorComp] - show η_ P.even Q.even ▷ P.odd ≫ - (α_ P.even Q.even P.odd).hom ≫ - P.even ◁ biprod.inl ≫ - (P.even ◁ (0 : (Q.even ⊗ P.odd ⊞ Q.odd ⊗ P.even) ⟶ - (0 : A))) ≫ - biprod.inl = 0 - simp · exact (isZero_zeroTensor _).eq_of_src _ _ /-- The doubling of a right rigid category is right rigid, with diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndDayClosure.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndDayClosure.lean index aa14067e62..89579b5da6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndDayClosure.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndDayClosure.lean @@ -109,8 +109,10 @@ theorem isIndObject_obj_of_preservesColimits (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) - exact (isIndObject_colimit Q.I E hE).map - (IsColimit.coconePointUniqueUpToIso (colimit.isColimit E) hc₃).hom + 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedConc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedConc.lean index 4cbbb8350e..3620d7a46c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedConc.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedConc.lean @@ -622,9 +622,9 @@ theorem tensorPowConcat_permAlg (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 - | hM σ => + | of σ => induction y using MonoidAlgebra.induction_on with - | hM τ => + | of τ => rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin a))) σ = MonoidAlgebra.single σ (1 : ℂ) from rfl, show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin b))) τ = @@ -632,16 +632,16 @@ theorem tensorPowConcat_permAlg blockAlgEmbed_single, one_mul, permAlg_single, permAlg_single, permAlg_single] exact tensorPowConcat_permMor X σ τ - | hadd y₁ y₂ hy₁ hy₂ => + | add y₁ y₂ hy₁ hy₂ => rw [blockAlgEmbed_add_snd, map_add, map_add] exact tensor_add_glue hy₁ hy₂ - | hsmul r y' hy => + | smul r y' hy => rw [blockAlgEmbed_smul_snd, map_smul, map_smul] exact tensor_smul_glue r hy - | hadd x₁ x₂ hx₁ hx₂ => + | add x₁ x₂ hx₁ hx₂ => rw [blockAlgEmbed_add_fst, map_add, map_add] exact add_tensor_glue hx₁ hx₂ - | hsmul r x' hx => + | smul r x' hx => rw [blockAlgEmbed_smul_fst, map_smul, map_smul] exact smul_tensor_glue r hx diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedDiag.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedDiag.lean index aa40ab7065..1c731bebbd 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedDiag.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedDiag.lean @@ -189,13 +189,10 @@ theorem tensorPowDistrib_swapTop 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) - calc (tensorPowDistrib X Y (n + 2)).hom - = ((((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 := rfl - _ = _ := by rw [h, Category.assoc] + 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) @@ -379,7 +376,7 @@ theorem diagAlg_apply [Preadditive A] [Linear ℂ A] (X Y : A) (n : ℕ) (x : SymGroupAlgebra n) : diagAlg X Y n x = - Finsupp.sum x fun σ c => + Finsupp.sum x.coeff fun σ c => c • (permMor X n σ ⊗ₘ permMor Y n σ) := by rw [diagAlg, MonoidAlgebra.lift_apply] rfl @@ -399,15 +396,15 @@ theorem tensorPowDistrib_permAlg 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 - | hM σ => + | of σ => rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n))) σ = MonoidAlgebra.single σ (1 : ℂ) from rfl, permAlg_single, diagAlg_single] exact tensorPowDistrib_permMor X Y n σ - | hadd x y hx hy => + | add x y hx hy => rw [map_add, map_add] exact intertwine_add hx hy - | hsmul r x hx => + | smul r x hx => rw [map_smul, map_smul] exact intertwine_smul r hx diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModCross.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModCross.lean index 4dba5390b6..20833f94c9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModCross.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModCross.lean @@ -194,7 +194,6 @@ lemma modCrossBridge_legM (P.X ◁ modMultiLegM A rest X Y m) rw [← MonoidalCategory.whiskerLeft_comp, modCrossBridge_legM A X Y m rest] - rfl /-- **The stationary window of a singleton block is the second relation leg** of the head slot, through the bridge. -/ @@ -243,7 +242,6 @@ lemma modCrossBridge_legN (P.X ◁ modMultiLegN A rest X Y m) rw [← MonoidalCategory.whiskerLeft_comp, modCrossBridge_legN A X Y m rest] - rfl end CrossBase @@ -385,7 +383,6 @@ lemma modCrossStepBridge_legM (Q.X ◁ modMultiLegM A rest X P (l' ++ Ys)) rw [← MonoidalCategory.whiskerLeft_comp, modCrossStepBridge_legM A X P l' Ys rest] - rfl /-- **The step bridge against the second relation leg**: past the head slot, what remains is the crossing of the tail block, under diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantExpand.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantExpand.lean index 81fde2f08a..b3a9c7e448 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantExpand.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantExpand.lean @@ -34,12 +34,11 @@ theorem stairShift_apply (τ : Equiv.Perm (Fin k)) (j : Fin k) : /-- **Coefficient extraction against the staircase alternant.** -/ theorem coeff_mul_alternant (P : MvPolynomial (Fin k) ℂ) (w₀ : Fin k →₀ ℕ) : - MvPolynomial.coeff w₀ - (P * (powMat (fun _ : Fin k => 0)).det) = + (P * (powMat (fun _ : Fin k => 0)).det).coeff w₀ = ∑ τ : Equiv.Perm (Fin k), ((Equiv.Perm.sign τ : ℤ) : ℂ) * (if stairShift τ ≤ w₀ - then MvPolynomial.coeff (w₀ - stairShift τ) P + then P.coeff (w₀ - stairShift τ) else 0) := by classical rw [Matrix.det_apply'] diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantStrict.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantStrict.lean index eb95ddbaee..e49e13d1c0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantStrict.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantStrict.lean @@ -67,7 +67,7 @@ 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) : - MvPolynomial.coeff (∑ i, Finsupp.single i (w i)) (altDet e) = + (altDet e).coeff (∑ i, Finsupp.single i (w i)) = if e = w then 1 else 0 := by classical by_cases heq : e = w diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HProdCoeff.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HProdCoeff.lean index 0af9cc43eb..ba9172567a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HProdCoeff.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HProdCoeff.lean @@ -42,7 +42,7 @@ 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 →₀ ℕ) : - MvPolynomial.coeff w (∏ i, hSub (Finset.univ : Finset (Fin k)) (c i)) = + (∏ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPermCast.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPermCast.lean index 4baec5c5f2..6a71d655e0 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPermCast.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPermCast.lean @@ -113,7 +113,8 @@ theorem permAlg_symCast 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 fun σ => ?_ + refine MonoidAlgebra.algHom_ext (R := ℂ) (A := ℂ) (M := Equiv.Perm (Fin m)) + (fun σ => ?_) (by ext) show 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowSplit.lean index f3ca1e4cec..a82635e924 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowSplit.lean @@ -269,26 +269,9 @@ theorem insertTop_comp_splitPow [Category.{v} A] [MonoidalCategory A] have hstep := whiskerRight_comp_splitPow X p (r + 1) (insertTop_comp_splitPow X p k r hkr) rw [hL, hR] - calc (swapTop X (p + r) ≫ (insertTop X (p + r) k ▷ X)) ≫ - (splitPow X p (r + 1 + 1)).hom - = swapTop X (p + r) ≫ ((insertTop X (p + r) k ▷ X) ≫ - (splitPow X p (r + 1 + 1)).hom) := Category.assoc _ _ _ - _ = swapTop X (p + r) ≫ ((splitPow X p (r + 1 + 1)).hom ≫ - (tensorPow A X p ◁ (insertTop X r k ▷ X))) := - congrArg (fun z => swapTop X (p + r) ≫ z) hstep - _ = (swapTop X (p + r) ≫ (splitPow X p (r + 1 + 1)).hom) ≫ - (tensorPow A X p ◁ (insertTop X r k ▷ X)) := - (Category.assoc _ _ _).symm - _ = ((splitPow X p (r + 1 + 1)).hom ≫ - (tensorPow A X p ◁ swapTop X r)) ≫ - (tensorPow A X p ◁ (insertTop X r k ▷ X)) := - congrArg - (fun z => z ≫ (tensorPow A X p ◁ (insertTop X r k ▷ X))) - (swapTop_comp_splitPow X p r) - _ = (splitPow X p (r + 1 + 1)).hom ≫ - (tensorPow A X p ◁ swapTop X r) ≫ - (tensorPow A X p ◁ (insertTop X r k ▷ X)) := - Category.assoc _ _ _ + erw [Category.assoc, hstep, ← Category.assoc, + swapTop_comp_splitPow X p r, Category.assoc] + rfl /-! ## Tensor powers respect the splitting -/ @@ -398,47 +381,11 @@ theorem permMor_comp_splitPow [Category.{v} A] [MonoidalCategory A] have hi := insertTop_comp_splitPow X p (q - (topImage τ : ℕ)) q hkq rw [hL, hR] - calc ((permMor X (p + q) (blockSum σ (restPerm τ)) ▷ X) ≫ - insertTop X (p + q) (q - (topImage τ : ℕ))) ≫ - (splitPow X p (q + 1)).hom - = (permMor X (p + q) (blockSum σ (restPerm τ)) ▷ X) ≫ - (insertTop X (p + q) (q - (topImage τ : ℕ)) ≫ - (splitPow X p (q + 1)).hom) := Category.assoc _ _ _ - _ = (permMor X (p + q) (blockSum σ (restPerm τ)) ▷ X) ≫ - ((splitPow X p (q + 1)).hom ≫ - (tensorPow A X p ◁ - insertTop X q (q - (topImage τ : ℕ)))) := - congrArg (fun z => - (permMor X (p + q) (blockSum σ (restPerm τ)) ▷ X) ≫ z) - hi - _ = ((permMor X (p + q) (blockSum σ (restPerm τ)) ▷ X) ≫ - (splitPow X p (q + 1)).hom) ≫ - (tensorPow A X p ◁ - insertTop X q (q - (topImage τ : ℕ))) := - (Category.assoc _ _ _).symm - _ = ((splitPow X p (q + 1)).hom ≫ - (permMor X p σ ⊗ₘ - (permMor X q (restPerm τ) ⊗ₘ 𝟙 X))) ≫ - (tensorPow A X p ◁ - insertTop X q (q - (topImage τ : ℕ))) := by - rw [← tensorHom_id - (permMor X (p + q) (blockSum σ (restPerm τ))) X, hw] - rfl - _ = (splitPow X p (q + 1)).hom ≫ - ((permMor X p σ ⊗ₘ - (permMor X q (restPerm τ) ⊗ₘ 𝟙 X)) ≫ - (𝟙 (tensorPow A X p) ⊗ₘ - insertTop X q (q - (topImage τ : ℕ)))) := by - rw [Category.assoc, id_tensorHom] - _ = (splitPow X p (q + 1)).hom ≫ - (permMor X p σ ⊗ₘ - ((permMor X q (restPerm τ) ⊗ₘ 𝟙 X) ≫ - insertTop X q (q - (topImage τ : ℕ)))) := by - rw [tensorHom_comp_tensorHom, Category.comp_id] - _ = (splitPow X p (q + 1)).hom ≫ - (permMor X p σ ⊗ₘ - ((permMor X q (restPerm τ) ▷ X) ≫ - insertTop X q (q - (topImage τ : ℕ)))) := by - rw [tensorHom_id] + 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 From c2a232e8c0e625cc0f053e716e26a064a5c51be2 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 21 Sep 2026 22:42:46 +0000 Subject: [PATCH 06/46] Port symmetric algebra and stabilize orientation and copairing proofs --- .../Classical/Deligne/EvenEmbedMonoidal.lean | 7 --- .../RS/Classical/Deligne/IndCompact.lean | 5 +- .../RS/Classical/Deligne/ModAbelian.lean | 14 +++-- .../RS/Classical/Deligne/ModContractL.lean | 4 +- .../RS/Classical/Deligne/PermNat.lean | 6 +- .../RS/Classical/Deligne/SymAlg.lean | 18 ++++-- .../RS/Classical/SchurTheory/BlockKill.lean | 6 +- .../RS/Classical/SymFun/JTDetExpand.lean | 9 +-- .../RS/Classical/SymFun/PieriChain.lean | 23 ++++---- .../RS/Classical/SymFun/PowCount.lean | 3 +- .../RS/Novel/Envelope/PermTrace.lean | 4 +- .../RS/Novel/Extraction/CopairUnique.lean | 57 +++++++++---------- .../RS/Novel/Skein/OrientationFlip.lean | 4 +- 13 files changed, 77 insertions(+), 83 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/EvenEmbedMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/EvenEmbedMonoidal.lean index 2836bf29b7..2ce90420c8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/EvenEmbedMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/EvenEmbedMonoidal.lean @@ -70,12 +70,10 @@ instance evenEmbedLaxMonoidal intro X Y f X' ext · simp [evenEmbedTensorIso, isoBiprodZero] - · exact (isZero_zero A).eq_of_tgt _ _ μ_natural_right := by intro X Y X' f ext · simp [evenEmbedTensorIso, isoBiprodZero] - · exact (isZero_zero A).eq_of_tgt _ _ associativity := by intro X Y Z ext @@ -84,21 +82,16 @@ instance evenEmbedLaxMonoidal -comp_whiskerRight, -MonoidalCategory.whiskerLeft_comp, ← comp_whiskerRight_assoc, ← MonoidalCategory.whiskerLeft_comp] - · exact (isZero_zero A).eq_of_tgt _ _ left_unitality := by intro X ext · apply biprod.hom_ext' <;> simp [evenEmbedTensorIso, isoBiprodZero, leftUnitorComp] - rfl - · exact (isZero_zero A).eq_of_tgt _ _ right_unitality := by intro X ext · apply biprod.hom_ext' <;> simp [evenEmbedTensorIso, isoBiprodZero, rightUnitorComp] - rfl - · exact (isZero_zero A).eq_of_tgt _ _ /-- The even embedding is strong monoidal: both comparisons are isomorphisms by construction. -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCompact.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCompact.lean index b89e088ca1..4469b8c169 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCompact.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCompact.lean @@ -67,10 +67,7 @@ noncomputable def indOfCoyonedaIso [SmallCategory C] (Ind.inclusion C).map (f ≫ h) ≫ 𝟙 _ = ((Ind.yonedaCompInclusion.app X).inv ≫ (Ind.inclusion C).map f ≫ 𝟙 _) ≫ (Ind.inclusion C).map h - simp - -- The residue is the definitional identification of the two - -- `TypeCat` hom-coercion routes through `Functor.comp`. - rfl) + simp) /-- **Objects of `C` are compact in `Ind C`**: the hom functor out of an embedded object preserves filtered colimits of any given small diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAbelian.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAbelian.lean index 3da2cf4738..e2e81ba1bb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAbelian.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAbelian.lean @@ -586,12 +586,13 @@ noncomputable def kerLift [Category.{v} D] [MonoidalCategory D] [Preadditive D] Mod.Hom.mk' (kernel.lift f.hom k.hom (by simpa using congrArg Mod.Hom.hom hk)) (by - show actLeft A W.X ≫ kernel.lift f.hom k.hom _ - = A ◁ kernel.lift f.hom k.hom _ ≫ kerAct A f + 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]) + 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] @@ -792,13 +793,14 @@ noncomputable def cokerDesc Mod.Hom.mk' (cokernel.desc f.hom k.hom (by simpa using congrArg Mod.Hom.hom hk)) (by - show cokerAct A f ≫ cokernel.desc f.hom k.hom _ - = A ◁ cokernel.desc f.hom k.hom _ ≫ actLeft A W.X + 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 haveI := 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]) + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModContractL.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModContractL.lean index 44acfe1967..0d0a6e9913 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModContractL.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModContractL.lean @@ -131,7 +131,7 @@ theorem contract3LFold_boundary_cond ((modTensorπ A M' M ≫ p) ▷ (N.X ⊗ 𝟙_ D)) ≫ ((α_ A N.X (𝟙_ D)).inv ≫ (actLeft A N.X ▷ (𝟙_ D))) ≫ modMultiπ A [N] - simp only [Category.assoc] + 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 @@ -175,7 +175,7 @@ theorem contract3LFold_boundary_cond MonoidalCategory.comp_whiskerRight, Category.assoc, Category.assoc, associator_inv_naturality_left_assoc, associator_inv_naturality_left_assoc] - conv_rhs => rw [MonoidalCategory.comp_whiskerRight, + conv_rhs => erw [MonoidalCategory.comp_whiskerRight, Category.assoc, associator_naturality_middle, MonoidalCategory.whiskerLeft_comp, MonoidalCategory.whiskerLeft_comp, Category.assoc, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermNat.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermNat.lean index 216f619f2d..d41bdce783 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermNat.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermNat.lean @@ -300,15 +300,15 @@ theorem permAlg_natural permAlg X n x ≫ tensorPowMap f n = tensorPowMap f n ≫ permAlg Y n x := by induction x using MonoidAlgebra.induction_on with - | hM σ => + | of σ => rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n))) σ = MonoidAlgebra.single σ (1 : ℂ) from rfl, permAlg_single, permAlg_single] exact permMor_natural f n σ - | hadd x y hx hy => + | add x y hx hy => rw [map_add, map_add] exact intertwine_add hx hy - | hsmul r x hx => + | smul r x hx => rw [map_smul, map_smul] exact intertwine_smul r hx diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymAlg.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymAlg.lean index 6fdd1c994a..69eda2620c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymAlg.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymAlg.lean @@ -214,7 +214,7 @@ theorem tensorPowConcat_peel [Category.{v} D] [MonoidalCategory D] (X : D) | q + 1 => by rw [tensorPowConcat_succ_hom X p (q + 1), tensorPowConcat_peel X p q] simp only [MonoidalCategory.comp_whiskerRight] - rw [powCast_whiskerRight, reassoc_of% (concat_peel_step X p q)] + 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 _ _ _)) @@ -879,7 +879,8 @@ private theorem adjSwap_rel_above conv_lhs => rw [reassoc_of% hcast] rw [modPowGlue] simp only [Category.assoc] - rw [reassoc_of% (ctx_above_aux A X + 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), @@ -945,7 +946,8 @@ private theorem adjSwap_rel_below conv_lhs => rw [reassoc_of% hcast] rw [modPowGlue] simp only [Category.assoc] - rw [reassoc_of% (ctx_below_aux A X + 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), @@ -1287,7 +1289,8 @@ private theorem legUpper_frame ((tensorPowConcat X (a + 1 + 2) q).hom ≫ powCast X h12 ≫ k) simp only [modPowGlue, winFrame, winFromUpper, whiskerRightIso_hom, Category.assoc] at h0 ⊢ - exact 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. -/ @@ -1358,6 +1361,7 @@ private theorem legLower_frame 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 @@ -1418,7 +1422,8 @@ private theorem winFrame_adjSwap_high Category.comp_id _) simp only [winFrame, winAssemble, adjSwapMor, swapTop, Category.assoc] at h0 ⊢ - exact 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. -/ @@ -1488,6 +1493,9 @@ private theorem winFrame_adjSwap_low (tensorPowConcat X (a + 2) (q + 1)) hCb simp only [winFrame, winAssemble, adjSwapMor, swapTop, Category.assoc] at h0 ⊢ + simp only [tensorPow, tensorPowConcat, Iso.trans_inv, whiskerRightIso_inv, + Iso.symm_inv, winAssemble, Category.assoc] at h0 ⊢ + repeat' erw [Category.assoc] at h0 exact h0 variable {A X} in diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BlockKill.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BlockKill.lean index d75d96d516..fcfe4a84be 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BlockKill.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BlockKill.lean @@ -29,7 +29,7 @@ theorem intertwiner_comp_asAlgebraHom [Group G] (σ g : W →ₗ[ℂ] W) ∘ₗ f) (y : MonoidAlgebra ℂ G) : f ∘ₗ ρ.asAlgebraHom y = σ.asAlgebraHom y ∘ₗ f := by induction y using MonoidAlgebra.induction_on with - | hM g => + | of g => rw [show MonoidAlgebra.of ℂ G g = MonoidAlgebra.single g (1 : ℂ) from rfl] rw [show (ρ.asAlgebraHom (MonoidAlgebra.single g 1) : @@ -39,10 +39,10 @@ theorem intertwiner_comp_asAlgebraHom [Group G] W →ₗ[ℂ] W) = (σ g : W →ₗ[ℂ] W) from by rw [Representation.asAlgebraHom_single, one_smul]] exact hf g - | hadd a b ha hb => + | add a b ha hb => rw [map_add, map_add, LinearMap.comp_add, LinearMap.add_comp, ha, hb] - | hsmul r a ha => + | smul r a ha => rw [map_smul, map_smul, LinearMap.comp_smul, LinearMap.smul_comp, ha] diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTDetExpand.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTDetExpand.lean index 3ed2d6cb40..b863203570 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTDetExpand.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTDetExpand.lean @@ -59,13 +59,13 @@ theorem jt_term_guard (v : Fin k → ℕ) (σ : Equiv.Perm (Fin k)) : /-- **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 →₀ ℕ) : - MvPolynomial.coeff w ((jtMat v).det) = + ((jtMat v).det).coeff w = ∑ σ : Equiv.Perm (Fin k), ((Equiv.Perm.sign σ : ℤ) : ℂ) * (if ∀ i : Fin k, 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) - then MvPolynomial.coeff w (∏ i, hSub (Finset.univ : Finset (Fin k)) - (((v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ)).toNat)) + 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] @@ -80,6 +80,7 @@ theorem coeff_det_jtMat (v : Fin k → ℕ) (w : Fin k →₀ ℕ) : by_cases hp : ∀ i : Fin k, 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) · rw [if_pos hp, if_pos hp] - · rw [if_neg hp, if_neg hp, MvPolynomial.coeff_zero] + · rw [if_neg hp, if_neg hp, AddMonoidAlgebra.coeff_zero] + rfl end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/PieriChain.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PieriChain.lean index 1209d39526..fac8a56dd7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/PieriChain.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PieriChain.lean @@ -39,8 +39,8 @@ 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 : ℕ, MvPolynomial.coeff (∑ i, Finsupp.single i (w i)) - ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r * altDet e) = N := by + ∃ 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 @@ -54,9 +54,8 @@ theorem coeff_pow_p1_altDet_natCast {k : ℕ} (r : ℕ) (w : Fin k → ℕ) MvPolynomial.coeff_sum] -- Each summand is a natural-number cast have hterm : ∀ i₀ : Fin k, ∃ N : ℕ, - MvPolynomial.coeff (∑ j, Finsupp.single j (w j)) - ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r * - altDet (Function.update e i₀ (e i₀ + 1))) = ↑N := by + ((∑ 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 @@ -65,7 +64,7 @@ theorem coeff_pow_p1_altDet_natCast {k : ℕ} (r : ℕ) (w : Fin k → ℕ) altDet_eq_zero_of_repeat _ hai (by rw [Function.update_of_ne hai _ _, Function.update_self] exact hae) - rw [hzero, mul_zero, MvPolynomial.coeff_zero] + 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 @@ -97,9 +96,8 @@ 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 ∧ - MvPolynomial.coeff (∑ i, Finsupp.single i (eVec mu k i)) - ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r * - altDet (eVec lam k)) = N := by + ((∑ 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 @@ -147,10 +145,9 @@ theorem coeff_chain_pos {k : ℕ} (lam mu : YoungDiagram) MvPolynomial.coeff_sum] -- Each summand is a ℕ-cast have hterm : ∀ i : Fin k, ∃ N : ℕ, - MvPolynomial.coeff (∑ j, Finsupp.single j (eVec mu k j)) - ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r * + ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r * altDet (Function.update (eVec lam k) i - (eVec lam k i + 1))) = ↑N := by + (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 @@ -158,7 +155,7 @@ theorem coeff_chain_pos {k : ℕ} (lam mu : YoungDiagram) rw [altDet_eq_zero_of_repeat _ hai (by rw [Function.update_of_ne hai _ _, Function.update_self] exact hae), - mul_zero, MvPolynomial.coeff_zero] + 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowCount.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowCount.lean index 1267187710..d2d67697c8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowCount.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowCount.lean @@ -21,8 +21,7 @@ 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 →₀ ℕ) : - MvPolynomial.coeff w - ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ Fintype.card T) = + ((∑ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/PermTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/PermTrace.lean index 3b7783682f..2f31ded0d6 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/PermTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/PermTrace.lean @@ -157,7 +157,8 @@ theorem catTrace_blockCycles (l.map (fun c => catTrace (g ^ c))).prod | [], _ => by show catTrace (permMor X 0 1 ≫ powHom X g 0) = 1 - rw [permMor_one, powHom_zero, Category.id_comp] + 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 := @@ -170,7 +171,6 @@ theorem catTrace_blockCycles rw [catTrace_permMor_blockSum, catTrace_permMor_finRotate, catTrace_blockCycles X g rest hrest, List.map_cons, List.prod_cons] - rfl /-! ## An arbitrary permutation -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/CopairUnique.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CopairUnique.lean index c0e835243b..58f675e979 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/CopairUnique.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CopairUnique.lean @@ -214,9 +214,18 @@ theorem formOddBlock_stdForm (k ℓ : ℕ) (x y : Fin (2 * ℓ) → ℂ) : /-! ### Uniqueness -/ --- Raised budget: instantiating the abstract contraction families at --- the standard model crosses the reduced and unreduced type --- presentations, so the definitional unification is heavy. +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 @@ -241,33 +250,23 @@ theorem stdCopair_unique (k ℓ : ℕ) obtain ⟨S, T, hS, hT, hi, _, hiii, _⟩ := exists_contraction_families (stdForm k ℓ) C' h1 h2 have he : ((formCoevMap C') 1).1 = stdCopairEvenElem k := by - refine contractionMap_injective (stdFormEvenBilin k) - (stdFormEvenBilin_nondegenerate k) (LinearMap.ext fun x => ?_) - exact ((DFunLike.congr_fun - ((congrArg (contractionMap (stdFormEvenBilin k)) hS).trans - (map_sum (contractionMap (stdFormEvenBilin k)) - (fun i => i.1 ⊗ₜ[ℂ] i.2) S)) x).trans - ((LinearMap.sum_apply S _ x).trans - ((Finset.sum_congr rfl fun i _ => - (contractionMap_tmul _ i.1 i.2 x).trans - (congrArg (· • i.2) - (formEvenBlock_stdForm k ℓ x i.1).symm)).trans - (hi x)))).trans - (contractionMap_stdCopairEvenElem k x).symm + 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 - refine contractionMap_injective (stdFormOddBilin ℓ) - (stdFormOddBilin_nondegenerate ℓ) (LinearMap.ext fun x => ?_) - exact ((DFunLike.congr_fun - ((congrArg (contractionMap (stdFormOddBilin ℓ)) hT).trans - (map_sum (contractionMap (stdFormOddBilin ℓ)) - (fun i => i.1 ⊗ₜ[ℂ] i.2) T)) x).trans - ((LinearMap.sum_apply T _ x).trans - ((Finset.sum_congr rfl fun i _ => - (contractionMap_tmul _ i.1 i.2 x).trans - (congrArg (· • i.2) - (formOddBlock_stdForm k ℓ x i.1).symm)).trans - (hiii x)))).trans - (contractionMap_stdCopairOddElem ℓ x).symm + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean index 8010f4f28e..d8cd045f05 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean @@ -802,8 +802,6 @@ end Diff /-! ## The orientation-invariance theorems -/ open Classical in --- Raised budget: invariance is proved over all internal flags at --- once, so the summand unfolds for both orientations. /-- **Invariance under circuit flips**: for a fixed relative transition system, the corrected constrained summand is invariant under changing the @@ -822,7 +820,7 @@ theorem throughSummand_orientation_invariant [LinearOrder α] F.throughSummand h st hbnd o c = F.throughSummand h st hbnd o' c := by unfold EdgeSubset.throughSummand - congr 1 + 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 From 6744e3e6cb1654bfebc3b39e53d94d0ada12efd3 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 21 Sep 2026 22:55:33 +0000 Subject: [PATCH 07/46] Update remaining coefficient and induction APIs and port tensor constructions --- .../RS/Classical/Deligne/BiprodPow.lean | 12 ++--- .../RS/Classical/Deligne/FreeCollapseAlg.lean | 6 +-- .../RS/Classical/Deligne/IdemCut.lean | 6 +-- .../RS/Classical/Deligne/IndKill.lean | 36 ++++++------- .../RS/Classical/Deligne/IndSchurKilled.lean | 6 +-- .../RS/Classical/Deligne/IndTensorExact.lean | 3 +- .../RS/Classical/Deligne/KronKill.lean | 24 ++++----- .../RS/Classical/Deligne/ModPowCast.lean | 6 +-- .../RS/Classical/Deligne/ModPowStage.lean | 12 +++-- .../RS/Classical/Deligne/PowAct.lean | 6 +-- .../RS/Classical/Deligne/PowPoint.lean | 50 ++++--------------- .../RS/Classical/Deligne/RegularSum.lean | 4 +- .../RS/Classical/Deligne/SchurTransport.lean | 6 +-- .../RS/Classical/Deligne/SuperVectSchur.lean | 6 +-- .../RS/Classical/Deligne/SymMul.lean | 30 +++++++---- .../Classical/SchurTheory/NativeAction.lean | 6 +-- .../RS/Classical/SchurTheory/PairingPos.lean | 30 ++++------- .../RS/Classical/SymFun/CoeffSplit.lean | 7 ++- .../RS/Classical/SymFun/TIdentity.lean | 10 ++-- .../RS/Novel/Coordinates/OmegaTensor.lean | 6 +-- .../RS/Novel/Skein/NonSeparatedStep.lean | 5 +- 21 files changed, 121 insertions(+), 156 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodPow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodPow.lean index 41738c1fa6..1e204bff1c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodPow.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodPow.lean @@ -477,7 +477,7 @@ 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 - rw [show H = rfl from rfl, eqToHom_refl, Category.comp_id, hfg] + 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 @@ -575,7 +575,7 @@ private theorem inl_pow_cast (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 - rw [show H = rfl from rfl, eqToHom_refl, Category.id_comp] + erw [show H = rfl from rfl, eqToHom_refl, Category.id_comp] rfl end Base @@ -818,7 +818,7 @@ private theorem insertTop_cast (eqToHom H ▷ Z) ≫ insertTop Z b k = insertTop Z a k ≫ (eqToHom H ▷ Z) := by subst hab - rw [show H = rfl from rfl, eqToHom_refl, + erw [show H = rfl from rfl, eqToHom_refl, MonoidalCategory.id_whiskerRight, Category.id_comp] exact (Category.comp_id _).symm @@ -833,7 +833,7 @@ private theorem cast_then_cast_whisker [Category.{v} A] [MonoidalCategory A] eqToHom H₁ ≫ (eqToHom H₂ ▷ Z) = eqToHom H₃ := by subst hbn subst hab - rw [show H₁ = rfl from rfl, show H₂ = rfl from rfl, + 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 @@ -942,7 +942,7 @@ theorem base_insert_true eqToHom (congrArg (tensorPow A (X ⊞ Y)) (Nat.succ_add_eq_add_succ p m)) := by rw [tensor_split_last] - simp only [Category.assoc] + repeat' erw [Category.assoc] rw [concat_whisker_insert, insertTop_full, MonoidalCategory.associator_naturality_assoc, tensor_then_whiskerLeft_assoc, @@ -1257,7 +1257,7 @@ private theorem comp_cast_end₃ [Category.{v} A] {g₁ : P ⟶ Q} {g₂ : Q ⟶ R} {g₃ : R ⟶ S} (H : S = S) (hfg : f = g₁ ≫ g₂ ≫ g₃) : f = g₁ ≫ g₂ ≫ g₃ ≫ eqToHom H := by - rw [show H = rfl from rfl, eqToHom_refl, Category.comp_id, hfg] + 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeCollapseAlg.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeCollapseAlg.lean index cbcb30aaed..0a0543577b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeCollapseAlg.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeCollapseAlg.lean @@ -59,15 +59,15 @@ theorem freeCollapse_permAlg (A ◁ (permAlg V n z : tensorPow D V n ⟶ tensorPow D V n)) := by induction z using MonoidAlgebra.induction_on with - | hM σ => + | of σ => rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n))) σ = MonoidAlgebra.single σ (1 : ℂ) from rfl, permAlg_single, permAlg_single] exact freeCollapse_permMor A V n σ - | hadd z₁ z₂ h₁ h₂ => + | add z₁ z₂ h₁ h₂ => rw [map_add, map_add] exact add_pass_free h₁ h₂ - | hsmul r z h => + | smul r z h => rw [map_smul, map_smul] exact smul_pass_free r h diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean index 8d3b3be10b..d3eb54a223 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean @@ -601,15 +601,15 @@ theorem modPowMap_alg (modPowAlg A X n z : End (modPow A X n)) ≫ modPowMap A f n := by induction z using MonoidAlgebra.induction_on with - | hM σ => + | of σ => rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n))) σ = MonoidAlgebra.single σ (1 : ℂ) from rfl, modPowAlg_single, modPowAlg_single] exact modPowMap_perm A f n σ - | hadd z₁ z₂ h₁ h₂ => + | add z₁ z₂ h₁ h₂ => rw [map_add, map_add] exact (intertwine_add h₁.symm h₂.symm).symm - | hsmul r z h => + | smul r z h => rw [map_smul, map_smul] exact (intertwine_smul r h.symm).symm diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean index 3964500776..ce2500df4c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean @@ -149,9 +149,9 @@ theorem blockImages_comm {a b : ℕ} (x : SymGroupAlgebra a) x := by classical induction x using MonoidAlgebra.induction_on with - | hM σ => + | of σ => induction y using MonoidAlgebra.induction_on with - | hM τ => + | of τ => have hL : MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedFstHom a b) (MonoidAlgebra.single σ 1) = MonoidAlgebra.single (blockEmbed σ 1) (1 : ℂ) := by @@ -170,13 +170,13 @@ theorem blockImages_comm {a b : ℕ} (x : SymGroupAlgebra a) congr 1 rw [← blockEmbed_mul, ← blockEmbed_mul] simp - | hadd y y' hy hy' => + | add y y' hy hy' => rw [map_add, mul_add, add_mul, hy, hy'] - | hsmul r y hy => + | smul r y hy => rw [map_smul, mul_smul_comm, smul_mul_assoc, hy] - | hadd x x' hx hx' => + | add x x' hx hx' => rw [map_add, add_mul, mul_add, hx, hx'] - | hsmul r x hx => + | smul r x hx => rw [map_smul, smul_mul_assoc, mul_smul_comm, hx] /-- The block embedding is multiplicative in the two slots @@ -243,9 +243,9 @@ theorem blockAlgEmbed_apply_blockEmbed {a b : ℕ} blockAlgEmbed x y (blockEmbed σ τ) = x σ * y τ := by classical induction x using MonoidAlgebra.induction_on with - | hM σ₀ => + | of σ₀ => induction y using MonoidAlgebra.induction_on with - | hM τ₀ => + | of τ₀ => simp only [MonoidAlgebra.of_apply] rw [blockAlgEmbed_single] by_cases hcase : σ₀ = σ ∧ τ₀ = τ @@ -257,17 +257,17 @@ theorem blockAlgEmbed_apply_blockEmbed {a b : ℕ} rcases not_and_or.mp hcase with hσ | hτ · simp [MonoidAlgebra.single_apply, hne, hσ] · simp [MonoidAlgebra.single_apply, hne, hτ] - | hadd y y' hy hy' => + | add y y' hy hy' => rw [blockAlgEmbed_add_snd, ma_add_apply, hy, hy', ma_add_apply, mul_add] - | hsmul r y hy => + | smul r y hy => rw [blockAlgEmbed_smul_snd, ma_smul_apply, hy, ma_smul_apply] ring - | hadd x x' hx hx' => + | add x x' hx hx' => rw [blockAlgEmbed_add_fst, ma_add_apply, hx, hx', ma_add_apply, add_mul] - | hsmul r x hx => + | smul r x hx => rw [blockAlgEmbed_smul_fst, ma_smul_apply, hx, ma_smul_apply] ring @@ -281,20 +281,20 @@ theorem blockAlgEmbed_apply_eq_zero {a b : ℕ} blockAlgEmbed x y g = 0 := by classical induction x using MonoidAlgebra.induction_on with - | hM σ₀ => + | of σ₀ => induction y using MonoidAlgebra.induction_on with - | hM τ₀ => + | of τ₀ => simp only [MonoidAlgebra.of_apply] rw [blockAlgEmbed_single] have hne : blockEmbed σ₀ τ₀ ≠ g := fun he => h σ₀ τ₀ he.symm simp [hne] - | hadd y y' hy hy' => + | add y y' hy hy' => rw [blockAlgEmbed_add_snd, ma_add_apply, hy, hy', add_zero] - | hsmul r y hy => + | smul r y hy => rw [blockAlgEmbed_smul_snd, ma_smul_apply, hy, mul_zero] - | hadd x x' hx hx' => + | add x x' hx hx' => rw [blockAlgEmbed_add_fst, ma_add_apply, hx, hx', add_zero] - | hsmul r x hx => + | smul r x hx => rw [blockAlgEmbed_smul_fst, ma_smul_apply, hx, mul_zero] /-- Convolution at the identity. -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean index 7af90bd1a8..639fbe3795 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean @@ -236,15 +236,15 @@ theorem permAlg_indOf_conj_scalarUnit letI := linearOfScalarUnit (indScalarUnit ψ) haveI := indOf_additive (C := C) induction x using MonoidAlgebra.induction_on with - | hM σ => + | of σ => rw [MonoidAlgebra.of_apply, permAlg_single, permAlg_single] exact indOfPowIso_permMor X n σ - | hadd p q hp hq => + | 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) - | hsmul c p hp => + | smul c p hp => rw [map_smul, map_smul] exact (scale_pass c hp).trans (congrArg (fun m => (indOfPowIso X n).hom ≫ m) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean index 29da7d96bc..ae38e873a4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean @@ -277,8 +277,7 @@ lemma eta_comp_dayCoyonedaIso_hom apply (coyonedaEquiv (C := D × D) (X := ((a, b) : D × D)) (F := tensor D ⋙ coyoneda.obj (op (a ⊗ b)))).injective refine h.trans ?_ - rw [coyonedaEquiv_apply, coyonedaEquiv_apply] - show 𝟙 (a ⊗ b) = 𝟙 a ⊗ₘ 𝟙 b + change 𝟙 (a ⊗ b) = 𝟙 a ⊗ₘ 𝟙 b simp /-- Naturality of `RS.dayCoyonedaIso` in the right variable. -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean index 5f7dde2a14..cead62807d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean @@ -103,9 +103,9 @@ theorem extImages_comm {n : ℕ} (x y : SymGroupAlgebra n) : MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) x := by classical induction x using MonoidAlgebra.induction_on with - | hM σ => + | of σ => induction y using MonoidAlgebra.induction_on with - | hM τ => + | of τ => have hL : MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) (MonoidAlgebra.single σ 1) = MonoidAlgebra.single @@ -126,13 +126,13 @@ theorem extImages_comm {n : ℕ} (x y : SymGroupAlgebra n) : rw [hL, hR, MonoidAlgebra.single_mul_single, MonoidAlgebra.single_mul_single] congr 1 - | hadd y y' hy hy' => + | add y y' hy hy' => rw [map_add, mul_add, add_mul, hy, hy'] - | hsmul r y hy => + | smul r y hy => rw [map_smul, mul_smul_comm, smul_mul_assoc, hy] - | hadd x x' hx hx' => + | add x x' hx hx' => rw [map_add, add_mul, mul_add, hx, hx'] - | hsmul r x hx => + | smul r x hx => rw [map_smul, smul_mul_assoc, mul_smul_comm, hx] /-- The external product is multiplicative in the two slots @@ -200,9 +200,9 @@ theorem extProd_apply_pair {n : ℕ} (x y : SymGroupAlgebra n) extProd x y (σ, τ) = x σ * y τ := by classical induction x using MonoidAlgebra.induction_on with - | hM σ₀ => + | of σ₀ => induction y using MonoidAlgebra.induction_on with - | hM τ₀ => + | of τ₀ => simp only [MonoidAlgebra.of_apply] rw [extProd_single] by_cases hcase : σ₀ = σ ∧ τ₀ = τ @@ -215,16 +215,16 @@ theorem extProd_apply_pair {n : ℕ} (x y : SymGroupAlgebra n) rcases not_and_or.mp hcase with hσ | hτ · simp [MonoidAlgebra.single_apply, hne, hσ] · simp [MonoidAlgebra.single_apply, hne, hτ] - | hadd y y' hy hy' => + | add y y' hy hy' => rw [extProd_add_snd, ma_add_apply, hy, hy', ma_add_apply, mul_add] - | hsmul r y hy => + | smul r y hy => rw [extProd_smul_snd, ma_smul_apply, hy, ma_smul_apply] ring - | hadd x x' hx hx' => + | add x x' hx hx' => rw [extProd_add_fst, ma_add_apply, hx, hx', ma_add_apply, add_mul] - | hsmul r x hx => + | smul r x hx => rw [extProd_smul_fst, ma_smul_apply, hx, ma_smul_apply] ring diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowCast.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowCast.lean index efb785fd9c..7fb142db0b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowCast.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowCast.lean @@ -141,15 +141,15 @@ theorem modPowπ_permAlg 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 - | hM σ => + | of σ => rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n))) σ = MonoidAlgebra.single σ (1 : ℂ) from rfl, modPowAlg_single, permAlg_single] exact modPowπ_perm n σ - | hadd x₁ x₂ h₁ h₂ => + | add x₁ x₂ h₁ h₂ => rw [map_add, map_add] exact add_pass h₁ h₂ - | hsmul r y hy => + | smul r y hy => rw [map_smul, map_smul] exact smul_pass r hy diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowStage.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowStage.lean index c6629c0cd5..7c12aa9a16 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowStage.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowStage.lean @@ -156,7 +156,7 @@ private theorem slot_whiskerRight (tensorPow D X b) X).inv).1 ?_ rw [MonoidalCategory.comp_whiskerRight, MonoidalCategory.comp_whiskerRight, powCast_whiskerRight] - simp only [Category.assoc] + repeat' erw [Category.assoc] exact ((Category.assoc _ _ _).symm.trans key).trans (Category.assoc _ _ _) @@ -170,12 +170,14 @@ theorem modPow_condition_succ (n : ℕ) : (modPowLegFst A X n ▷ X) ≫ modPowπ A X (n + 1) = (modPowLegSnd A X n ▷ X) ≫ modPowπ A X (n + 1) := by - rw [modPowLegFst, modPowLegSnd, desc_whiskerRight, + erw [modPowLegFst, modPowLegSnd, desc_whiskerRight, desc_whiskerRight, Preadditive.sum_comp, Preadditive.sum_comp] refine Finset.sum_congr rfl fun i _ => ?_ - simp only [Category.assoc] - exact whisker_eq _ (slot_whiskerRight A X i.val (n - 2 - i.val) - (slot_decomp 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowAct.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowAct.lean index 88277e97b8..2a5a2d26b2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowAct.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowAct.lean @@ -1015,14 +1015,14 @@ theorem modPowAct_alg End (modPow A X (n + 1)))) ≫ modPowAct A X n := by induction z using MonoidAlgebra.induction_on with - | hM σ => + | of σ => rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin (n + 1)))) σ = MonoidAlgebra.single σ (1 : ℂ) from rfl, modPowAlg_single] exact modPowAct_perm A X n σ - | hadd z₁ z₂ h₁ h₂ => + | add z₁ z₂ h₁ h₂ => rw [map_add] exact whisker_act_add (modPowAct A X n) h₁ h₂ - | hsmul r z' h => + | smul r z' h => rw [map_smul] exact whisker_act_smul (modPowAct A X n) r h diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPoint.lean index 97f697cf7e..b5853cb3da 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPoint.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPoint.lean @@ -33,7 +33,7 @@ theorem swapTop_unit [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (n : ℕ) : swapTop (𝟙_ D) n = 𝟙 (tensorPow D (𝟙_ D) (n + 2)) := by unfold swapTop - rw [braiding_unit_self, MonoidalCategory.whiskerLeft_id, + erw [braiding_unit_self, MonoidalCategory.whiskerLeft_id, Category.id_comp, Iso.hom_inv_id] /-- Every adjacent transposition acts trivially on a power of the @@ -219,45 +219,15 @@ theorem tensorPowPoint_concat monoidal refine Eq.trans ?_ (whisker_eq (λ_ (𝟙_ D)).hom (tensorPowPoint_succ (pt := pt) (m + n)).symm) - calc (tensorPowPoint pt m ⊗ₘ tensorPowPoint pt (n + 1)) ≫ - (tensorPowConcat Y m (n + 1)).hom - = (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) := by - rw [hsucc] - rfl - _ = ((𝟙 (𝟙_ D)) ⊗ₘ (ρ_ (𝟙_ D)).inv) ≫ - ((tensorPowPoint pt m ⊗ₘ - (tensorPowPoint pt n ⊗ₘ pt)) ≫ - (α_ (tensorPow D Y m) (tensorPow D Y n) Y).inv) ≫ - ((tensorPowConcat Y m n).hom ▷ Y) := by - rw [hdec] - simp only [Category.assoc] - _ = ((𝟙 (𝟙_ D)) ⊗ₘ (ρ_ (𝟙_ D)).inv) ≫ - (α_ (𝟙_ D) (𝟙_ D) (𝟙_ D)).inv ≫ - (((tensorPowPoint pt m ⊗ₘ - tensorPowPoint pt n) ⊗ₘ pt) ≫ - ((tensorPowConcat Y m n).hom ▷ Y)) := by - rw [hα] - simp only [Category.assoc] - _ = ((𝟙 (𝟙_ D)) ⊗ₘ (ρ_ (𝟙_ D)).inv) ≫ - (α_ (𝟙_ D) (𝟙_ D) (𝟙_ D)).inv ≫ - (((λ_ (𝟙_ D)).hom ≫ tensorPowPoint pt (m + n)) ⊗ₘ - pt) := by - rw [hIH] - _ = ((𝟙 (𝟙_ D)) ⊗ₘ (ρ_ (𝟙_ D)).inv) ≫ - (α_ (𝟙_ D) (𝟙_ D) (𝟙_ D)).inv ≫ - ((λ_ (𝟙_ D)).hom ▷ (𝟙_ D)) ≫ - (tensorPowPoint pt (m + n) ⊗ₘ pt) := by - rw [← MonoidalCategory.tensorHom_id - ((λ_ (𝟙_ D)).hom), - MonoidalCategory.tensorHom_comp_tensorHom, - Category.id_comp] - _ = (λ_ (𝟙_ D)).hom ≫ (ρ_ (𝟙_ D)).inv ≫ - (tensorPowPoint pt (m + n) ⊗ₘ pt) := by - rw [reassoc_of% hcoh] + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean index 078e9c7b34..36e4cef89d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean @@ -276,9 +276,7 @@ theorem diagramSchur_injective {lam mu : YoungDiagram} 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 : MvPolynomial.coeff - (∑ i, Finsupp.single i (eVec lam k i)) - (altDet (eVec lam k)) = 1 := by + 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), if_pos rfl] rw [halt, alternant_coeff_strict _ _ (eVec_strict mu k) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean index ce68677e36..92229f7a2d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean @@ -420,15 +420,15 @@ theorem permAlg_indOf_conj {C : Type v} [SmallCategory C] [MonoidalCategory C] letI := linearOfScalarUnit (indScalarUnit ψ) haveI := indOf_additive (C := C) induction x using MonoidAlgebra.induction_on with - | hM σ => + | of σ => rw [MonoidAlgebra.of_apply, permAlg_single, permAlg_single] exact indOfPowIso_permMor X n σ - | hadd p q hp hq => + | 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) - | hsmul c p hp => + | smul c p hp => rw [map_smul, map_smul] exact (smul_pass c hp).trans (congrArg (fun m => (indOfPowIso X n).hom ≫ m) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean index 620100c093..a599ac2493 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean @@ -1237,7 +1237,7 @@ theorem gradedSignRep_asAlgebraHom (p q n : ℕ) (gradedSignRep p q n).asAlgebraHom z = tot (permAlg (stdSuper p q) n z) := by induction z using MonoidAlgebra.induction_on with - | hM σ => + | of σ => show (gradedSignRep p q n).asAlgebraHom (MonoidAlgebra.single σ (1 : ℂ)) = tot (permAlg (stdSuper p q) n @@ -1245,11 +1245,11 @@ theorem gradedSignRep_asAlgebraHom (p q n : ℕ) rw [Representation.asAlgebraHom_single, one_smul, gradedSignRep_apply] exact congrArg tot (permAlg_single _ _ σ).symm - | hadd a b ha hb => + | 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 - | hsmul r a ha => + | smul r a ha => rw [map_smul, map_smul, ha] exact (tot_smul r (permAlg (stdSuper p q) n a)).symm diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean index 09b3638946..fd9125e656 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean @@ -120,13 +120,14 @@ theorem tensorPowConcat_assoc [Category.{v} D] [MonoidalCategory D] (X : D) ((tensorPowConcat X p (q + r)).hom ▷ X)) ≫ powCast X (by omega : p + (q + (r + 1)) = p + q + (r + 1)) rw [hcast, powExpose, powExpose, powExpose] - simp only [Category.assoc] at hstep ⊢ + repeat' erw [Category.assoc] at hstep + 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 ⊢ - rw [reassoc_of% hstep] + erw [reassoc_of% hstep] rfl /-- Concatenation with an empty first block is the left unitor, up @@ -315,6 +316,7 @@ theorem modPowLeg_concat_fst 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. -/ @@ -398,6 +400,7 @@ theorem modPowLeg_concat_snd 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 @@ -846,9 +849,9 @@ theorem modPowMul_alg 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 - | hM σ => + | of σ => induction y using MonoidAlgebra.induction_on with - | hM τ => + | of τ => rw [show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin m))) σ = MonoidAlgebra.single σ (1 : ℂ) from rfl, show (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n))) τ = @@ -856,16 +859,16 @@ theorem modPowMul_alg blockAlgEmbed_single, one_mul, modPowAlg_single, modPowAlg_single, modPowAlg_single] exact modPowMul_perm A X m n σ τ - | hadd y₁ y₂ hy₁ hy₂ => + | add y₁ y₂ hy₁ hy₂ => rw [blockAlgEmbed_add_snd, map_add, map_add] exact tensor_add_glue hy₁ hy₂ - | hsmul r y' hy => + | smul r y' hy => rw [blockAlgEmbed_smul_snd, map_smul, map_smul] exact tensor_smul_glue r hy - | hadd x₁ x₂ hx₁ hx₂ => + | add x₁ x₂ hx₁ hx₂ => rw [blockAlgEmbed_add_fst, map_add, map_add] exact add_tensor_glue hx₁ hx₂ - | hsmul r x' hx => + | smul r x' hx => rw [blockAlgEmbed_smul_fst, map_smul, map_smul] exact smul_tensor_glue r hx @@ -1606,7 +1609,7 @@ theorem tensorPowConcat_braiding_exists permMor X (n + m) σ) ▷ X) := by conv_lhs => rw [MonoidalCategory.comp_whiskerRight, reassoc_of% g4, ← comm_beta_expand X m n, hτ] - simp only [Category.assoc] + repeat' erw [Category.assoc] rfl have hw : ((powCast X (by omega : m + n = n + m) ≫ permMor X (n + m) σ) ▷ X) = @@ -1653,8 +1656,15 @@ theorem tensorPowConcat_braiding_exists (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), hw] + rw [reassoc_of% (comm_head X m n)] exact hfinal exact g1.trans (g2.trans (e3a.trans e3b)) diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeAction.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeAction.lean index dd41fa1603..ee0b883012 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeAction.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeAction.lean @@ -94,18 +94,18 @@ theorem isIrredRep_rhoS m ∈ p → y • m ∈ p := by intro y induction y using MonoidAlgebra.induction_on with - | hM g => + | 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 - | hadd a b ha hb => + | add a b ha hb => intro m hm rw [add_smul] exact p.add_mem (ha m hm) (hb m hm) - | hsmul r a ha => + | smul r a ha => intro m hm rw [smul_assoc] exact p.smul_mem r (ha m hm) diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean index 74c924e3c7..9c958d5f80 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean @@ -86,9 +86,8 @@ private theorem inner_sum_eq {m n k : ℕ} (h : m ≤ n) (colourChar α (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ) : ℂ)) = (m.factorial : ℂ) * - MvPolynomial.coeff (∑ a, Finsupp.single a (α a)) - ((∏ i, hSub (Finset.univ : Finset (Fin k)) (β i)) * - (∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ (n - m)) := by + ((∏ 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 @@ -216,14 +215,13 @@ private theorem inner_sum_eq {m n k : ℕ} (h : m ≤ n) open scoped Classical in private theorem coeff_det_jtMat_mul {k : ℕ} (v : Fin k → ℕ) (Q : MvPolynomial (Fin k) ℂ) (w : Fin k →₀ ℕ) : - MvPolynomial.coeff w ((jtMat v).det * Q) = + ((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 MvPolynomial.coeff w - ((∏ i, hSub (Finset.univ : Finset (Fin k)) - (((v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ)).toNat)) * Q) + 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 @@ -269,10 +267,8 @@ private theorem pairing_eq_factorial_coeff (hsum_mu : ∑ i : Fin k, mu.rowLen (i : ℕ) = n) : restrPairing lam mu h = (m.factorial : ℂ) * - MvPolynomial.coeff - (∑ i : Fin k, Finsupp.single i (eVec mu k i)) - ((∑ l : Fin k, (X l : MvPolynomial (Fin k) ℂ)) ^ r * - altDet (eVec lam k)) := by + ((∑ 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 @@ -288,13 +284,11 @@ private theorem pairing_eq_factorial_coeff ∀ i : Fin k, 0 ≤ (vm i : ℤ) + ((τ i : Fin k) : ℕ) - (i : ℕ) -- ═══════ STAGE 1: THE COEFFICIENT AS A DOUBLE SUM ═══════ have rhs_chain : - MvPolynomial.coeff (∑ i : Fin k, Finsupp.single i (eVec mu k i)) - (Q * altDet (eVec lam k)) = + (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 MvPolynomial.coeff (∑ a, Finsupp.single a (α τ a)) - ((∏ i, hSub (Finset.univ : Finset (Fin k)) (β σ' i)) * Q) + 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)) = @@ -323,8 +317,7 @@ private theorem pairing_eq_factorial_coeff have hsum_zero : (∑ σ' : Equiv.Perm (Fin k), ((Equiv.Perm.sign τ : ℤ) : ℂ) * ((Equiv.Perm.sign σ' : ℤ) : ℂ) * (if guard_mu τ ∧ guard_lam σ' - then MvPolynomial.coeff (∑ a, Finsupp.single a (α τ a)) - ((∏ i, hSub (Finset.univ : Finset (Fin k)) (β σ' i)) * Q) + 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 [if_neg (fun ⟨h, _⟩ => hguard_mu_neg h)]; ring @@ -336,8 +329,7 @@ private theorem pairing_eq_factorial_coeff ∑ σ' : Equiv.Perm (Fin k), ∑ τ : Equiv.Perm (Fin k), ((Equiv.Perm.sign σ' : ℤ) : ℂ) * ((Equiv.Perm.sign τ : ℤ) : ℂ) * (if guard_lam σ' ∧ guard_mu τ - then MvPolynomial.coeff (∑ a, Finsupp.single a (α τ a)) - ((∏ i, hSub (Finset.univ : Finset (Fin k)) (β σ' i)) * Q) + then ((∏ i, hSub (Finset.univ : Finset (Fin k)) (β σ' i)) * Q).coeff (∑ a, Finsupp.single a (α τ a)) else 0) := by -- Expand restrPairing unfold restrPairing diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffSplit.lean index fd4de21887..6c50bd901a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffSplit.lean @@ -24,13 +24,12 @@ open scoped Classical in /-- **The guarded pointwise convolution.** -/ theorem coeff_mul_split (P Q : MvPolynomial (Fin k) ℂ) (α : Fin k → ℕ) (n : ℕ) (hn : ∀ a, α a ≤ n) : - MvPolynomial.coeff (∑ a, Finsupp.single a (α a)) (P * Q) = + (P * Q).coeff (∑ a, Finsupp.single a (α a)) = ∑ w ∈ Fintype.piFinset (fun _ : Fin k => Finset.range (n + 1)), (if ∀ a, w a ≤ α a - then MvPolynomial.coeff - (∑ a, Finsupp.single a (α a - w a)) P * - MvPolynomial.coeff (∑ a, Finsupp.single a (w a)) Q + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/TIdentity.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/TIdentity.lean index 4c1db7688c..4001800dc7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/TIdentity.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/TIdentity.lean @@ -37,18 +37,16 @@ theorem t_identity (v : Fin k → ℕ) ((Equiv.Perm.sign σ : ℤ) : ℂ) * (if ∀ i : Fin k, 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) - then MvPolynomial.coeff (diagExp v - stairShift τ) - (∏ i, hSub (Finset.univ : Finset (Fin k)) + then (∏ i, hSub (Finset.univ : Finset (Fin k)) (((v i : ℤ) + ((σ i : Fin k) : ℕ) - - (i : ℕ)).toNat)) + (i : ℕ)).toNat)).coeff (diagExp v - stairShift τ) else 0) else 0)) = 1 := by classical - have h1 : MvPolynomial.coeff (diagExp v) ((powMat v).det) = 1 := + have h1 : ((powMat v).det).coeff (diagExp v) = 1 := alternant_coeff (fun i : Fin k => v i + ((k - 1) - (i : ℕ))) hinj - have h2 : MvPolynomial.coeff (diagExp v) - ((jtMat v).det * (powMat (fun _ : Fin k => 0)).det) = 1 := by + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean index 22224da377..65917d74f2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean @@ -124,12 +124,12 @@ 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) : - letI := P.braided - omegaVec f P (p ⊗ₘ q) = + 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 - letI := P.braided + let _ := P.braided have hskein : ((λ_ (𝟙_ (SkeinObj f))).inv ≫ (p ⊗ₘ q) : 𝟙_ (SkeinObj f) ⟶ SkeinObj.mk a ⊗ SkeinObj.mk b) = p ⊗ₘ q := by diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/NonSeparatedStep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/NonSeparatedStep.lean index 3b378f98d7..0c5a89c511 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/NonSeparatedStep.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/NonSeparatedStep.lean @@ -1394,9 +1394,6 @@ private theorem phiSum (hd : SegData κ κ' o o' S v P Q R T) end SegData --- Raised budget: the parametric core carries the segment data, --- both orientations and the boundary state through one --- elaboration. /-- The parametric core of the flipped-segment ledger. -/ private theorem throughSummand_seg_core [LinearOrder α] (hM : MixedFunctional k ℓ) (st : GenBoundaryState k ℓ α) @@ -1407,7 +1404,7 @@ private theorem throughSummand_seg_core [LinearOrder α] F.throughSummand hM st hbnd o' n = F.throughSummand hM st hbnd o n := by unfold EdgeSubset.throughSummand - congr 1 + 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 From e47d2123fb77ff1987eb286b3deb56dd3dea3ea3 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 21 Sep 2026 23:14:35 +0000 Subject: [PATCH 08/46] Port tensor coherence and skein assembly proofs to current Mathlib --- .../RS/Classical/Deligne/ChainAlgebra.lean | 12 ++-- .../RS/Classical/Deligne/FreePow.lean | 2 +- .../RS/Classical/Deligne/IndCoeq.lean | 6 +- .../RS/Classical/Deligne/IndSchur.lean | 37 ++++++------ .../RS/Classical/Deligne/OddLinePairing.lean | 2 - .../RS/Classical/Deligne/OddPermSign.lean | 2 +- .../RS/Classical/Deligne/PowAct.lean | 2 +- .../RS/Classical/Deligne/Rappel210Reduce.lean | 56 ++++++++++--------- .../RS/Classical/Deligne/WordMap.lean | 8 +-- .../RS/Classical/Deligne/ZigzagCarrier.lean | 18 +++--- .../RS/Classical/SchurTheory/CharDecomp.lean | 5 +- .../RS/Classical/Super/ColourConjTop.lean | 6 +- .../RS/Novel/Skein/LoopExample.lean | 2 +- .../RS/Novel/Skein/PairedAssembly.lean | 11 ++-- 14 files changed, 87 insertions(+), 82 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainAlgebra.lean index 2533161458..efceda047e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainAlgebra.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainAlgebra.lean @@ -239,7 +239,7 @@ theorem ι_chainMulStage [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (smallNatEquiv.functor.obj i)) ≫ chainMulStage B δ mu hδl j = mu i j ≫ chainColimitι B δ (i + 1 + j) - rw [chainMulStage, ι_preservesColimitIso_hom_assoc] + erw [chainMulStage, ι_preservesColimitIso_hom_assoc] exact colimit.ι_desc (chainMulCocone B δ mu hδl j) (smallNatEquiv.functor.obj i) @@ -257,7 +257,7 @@ theorem chainColimit_tensorRight_hom_ext (chainDiagram B δ)).inv).mp apply colimit.hom_ext intro k - rw [ι_preservesColimitIso_inv_assoc, + erw [ι_preservesColimitIso_inv_assoc, ι_preservesColimitIso_inv_assoc] exact w (smallNatEquiv.inverse.obj k) @@ -295,7 +295,7 @@ theorem tensorLeft_chainColimit_hom_ext (chainDiagram B δ)).inv).mp apply colimit.hom_ext intro k - rw [ι_preservesColimitIso_inv_assoc, + erw [ι_preservesColimitIso_inv_assoc, ι_preservesColimitIso_inv_assoc] exact w (smallNatEquiv.inverse.obj k) @@ -366,7 +366,7 @@ theorem whiskerLeft_ι_chainColimitMul (smallNatEquiv.functor.obj j)) ≫ chainColimitMul B δ mu hδl hδr = chainMulStage B δ mu hδl j - rw [chainColimitMul, ι_preservesColimitIso_hom_assoc] + erw [chainColimitMul, ι_preservesColimitIso_hom_assoc] exact colimit.ι_desc (chainMulTotalCocone B δ mu hδl hδr) (smallNatEquiv.functor.obj j) @@ -449,7 +449,7 @@ theorem ι_chainMulStageL [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ (smallNatEquiv.functor.obj j)) ≫ chainMulStageL B δ mu hδr i = mu i j ≫ chainColimitι B δ (i + 1 + j) - rw [chainMulStageL, ι_preservesColimitIso_hom_assoc] + erw [chainMulStageL, ι_preservesColimitIso_hom_assoc] exact colimit.ι_desc (chainMulLCocone B δ mu hδr i) (smallNatEquiv.functor.obj j) @@ -515,7 +515,7 @@ theorem chainColimit_sandwich_hom_ext (tensorRight Y ⋙ tensorLeft X) (chainDiagram B δ)).inv).mp apply colimit.hom_ext intro k - rw [ι_preservesColimitIso_inv_assoc, + erw [ι_preservesColimitIso_inv_assoc, ι_preservesColimitIso_inv_assoc] exact w (smallNatEquiv.inverse.obj k) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePow.lean index 0fd79ce6de..debea194a8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePow.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePow.lean @@ -102,7 +102,7 @@ theorem swapTop_muFold (((muFold A n ▷ A) ≫ μ[A]) ▷ A) ≫ μ[A] := rfl rw [hM] unfold swapTop - simp only [Category.assoc] + repeat' erw [Category.assoc] exact braidTop_mul' A (muFold A n) /-- **Bubbling is absorbed by the fold.** -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCoeq.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCoeq.lean index 250c54f3ff..7a49a6a4aa 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCoeq.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCoeq.lean @@ -145,7 +145,7 @@ lemma preservesColimit_flip_lim (colimit.ι (G.flip ⋙ lim) a ≫ (HasColimit.isoOfNatIso (limitIsoFlipCompLim G).symm).hom ≫ (colimitLimitIso G).hom) ≫ limit.π (colimit G.flip) b = - limit.π (G ⋙ (evaluation K 𝒟).obj a) 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) @@ -156,8 +156,8 @@ lemma preservesColimit_flip_lim (fun t => (limitIsoFlipCompLim G).symm.hom.app a ≫ t) (ι_colimitLimitIso_limit_π G a b)).trans ?_ refine (Category.assoc _ _ _).symm.trans ?_ - exact congrArg (fun t => t ≫ (colimit.ι G.flip a).app b) - (limitObjIsoLimitCompEvaluation_inv_π_app G b a) + apply congrArg (fun t => t ≫ (colimit.ι G.flip a).app b) + simp [limitIsoFlipCompLim, Category.assoc] exact hL.trans hR.symm haveI : IsIso (colimit.post G.flip lim) := by rw [key] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchur.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchur.lean index 3503f17acc..b4b0596921 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchur.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchur.lean @@ -204,8 +204,7 @@ lemma dayCoyonedaCorepresentableBy_homEquiv_iso (coyonedaDayCorepresentableBy (p ⊗ q)) = dayCoyonedaIso p q from rfl] at h rw [h] - dsimp [coyonedaDayCorepresentableBy] - rw [coyonedaEquiv_apply] + change coyonedaEquiv (𝟙 (coyoneda.obj (op (p ⊗ q)))) = 𝟙 (p ⊗ q) rfl /-- `RS.dayCoyonedaIso` sends the canonical element to the @@ -330,16 +329,18 @@ lemma dayCoyonedaIso_hom_associator [SmallCategory D] [MonoidalCategory D] (dayCoyonedaIso b c).hom) ≫ (dayCoyonedaIso a (b ⊗ c)).hom := by apply (dayCoyonedaCorepresentableBy₂ a b c).homEquiv.injective - simp only [← Category.assoc] - rw [(dayCoyonedaCorepresentableBy₂ a b c).homEquiv_comp, - (dayCoyonedaCorepresentableBy₂ a b c).homEquiv_comp, - (dayCoyonedaCorepresentableBy₂ a b c).homEquiv_comp, - (dayCoyonedaCorepresentableBy₂ a b c).homEquiv_comp, - dayCoyonedaCorepresentableBy₂_homEquiv_apply, - dayCoyonedaCorepresentableBy₂_homEquiv_apply, - dayEvaluation_map_apply, dayEvaluation_map_apply, - dayEvaluation_map_apply, dayEvaluation_map_apply, - whiskerRight_dayCoyonedaIso_app_unitElt, + 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) @@ -389,11 +390,13 @@ lemma dayCoyonedaIso_hom_braiding (dayCoyonedaIso b a).hom = (dayCoyonedaIso a b).hom ≫ ⟨coyoneda.map ((β_ b a).hom.op)⟩ := by apply (dayCoyonedaCorepresentableBy a b).homEquiv.injective - rw [(dayCoyonedaCorepresentableBy a b).homEquiv_comp, - (dayCoyonedaCorepresentableBy a b).homEquiv_comp, - dayCoyonedaCorepresentableBy_homEquiv_iso, - dayEvaluation_map_apply, dayEvaluation_map_apply, - dayCoyonedaCorepresentableBy_homEquiv_apply] + 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) = diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLinePairing.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLinePairing.lean index 5ef646eb3f..43e62e92e7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLinePairing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLinePairing.lean @@ -34,7 +34,6 @@ theorem neg_id_whiskerRight show (tensorRight Y).map (-𝟙 X) = _ rw [Functor.map_neg] simp - rfl /-- Whiskering a negated identity on the left negates it. -/ theorem whiskerLeft_neg_id [Category.{v} D] [MonoidalCategory D] [Preadditive D] @@ -44,7 +43,6 @@ theorem whiskerLeft_neg_id [Category.{v} D] [MonoidalCategory D] [Preadditive D] show (tensorLeft X).map (-𝟙 Y) = _ rw [Functor.map_neg] simp - rfl /-- **Cyclic rearrangement of a triple of lines is free**: the two transpositions each contribute a sign, and the signs diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddPermSign.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddPermSign.lean index 042e91d3f9..0b5e85afea 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddPermSign.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddPermSign.lean @@ -37,7 +37,7 @@ theorem oddLine_swapTop (L : OddLine D) (n : ℕ) : swapTop L.obj n = -𝟙 (tensorPow D L.obj (n + 2)) := by unfold swapTop - rw [L.braid_neg, whiskerLeft_neg, MonoidalCategory.whiskerLeft_id, + erw [L.braid_neg, whiskerLeft_neg, MonoidalCategory.whiskerLeft_id, Preadditive.neg_comp, Category.id_comp, Preadditive.comp_neg, Iso.hom_inv_id] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowAct.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowAct.lean index 2a5a2d26b2..dfb1c3a897 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowAct.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowAct.lean @@ -429,7 +429,7 @@ private theorem leg_split_below ((tensorPowConcat X (a + 2) b).hom) simp only [modPowGlue, tensorPowConcat_succ_hom, powExpose, comp_whiskerRight, Category.assoc] at h0 ⊢ - exact 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Reduce.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Reduce.lean index 3540659219..3b4e235d83 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Reduce.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Reduce.lean @@ -366,28 +366,28 @@ theorem freeSectionHom_section associator_inv_naturality_middle_assoc, ← MonoidalCategory.comp_whiskerRight, MonObj.mul_one] monoidal - calc 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 _ _ _)))) - _ = (B ◁ (pointSection S B cls ≫ - (β_ (unitFormMid S) B).hom ≫ - (B ◁ (unitForm S).g))) ≫ - (α_ B B (𝟙_ D)).inv ≫ (μ[B] ▷ (𝟙_ D)) := by - simp only [MonoidalCategory.whiskerLeft_comp, - Category.assoc] - _ = (B ◁ ((ρ_ (𝟙_ D)).inv ≫ (η[B] ▷ (𝟙_ D)))) ≫ - (α_ B B (𝟙_ D)).inv ≫ (μ[B] ▷ (𝟙_ D)) := by - rw [hinner] - rfl - _ = 𝟙 (B ⊗ 𝟙_ D) := hfold + 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, @@ -569,19 +569,23 @@ theorem freeSectionPoint_g 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 - rw [← MonoidalCategory.whiskerLeft_comp, + 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 _ - ((whisker_eq _ hpull).trans - ((Category.assoc _ _ _).symm.trans - ((eq_whisker hsec _).trans (Category.id_comp _))))) + ((Category.assoc _ _ _).trans hsection)) /-- **The transferred point**: the free-section element, contracted against the argument. -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/WordMap.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/WordMap.lean index 2cb39f9374..e0d703c05b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/WordMap.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/WordMap.lean @@ -303,7 +303,7 @@ theorem wordMap_standard (wordMap f g (p + q + 1) (standardWord p (q + 1))) (wordMap f g (p + q) (standardWord p q) ⊗ₘ g) hsplit).trans ?_ - rw [Category.assoc] + 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) @@ -465,7 +465,7 @@ private theorem insertTop_cast (eqToHom H ▷ T) ≫ insertTop T b k = insertTop T a k ≫ (eqToHom H ▷ T) := by subst hab - rw [show H = rfl from rfl, eqToHom_refl, + erw [show H = rfl from rfl, eqToHom_refl, MonoidalCategory.id_whiskerRight, Category.id_comp] exact (Category.comp_id _).symm @@ -480,7 +480,7 @@ private theorem cast_then_cast_whisker [Category.{v} A] [MonoidalCategory A] eqToHom H₁ ≫ (eqToHom H₂ ▷ T) = eqToHom H₃ := by subst hbn subst hab - rw [show H₁ = rfl from rfl, show H₂ = rfl from rfl, + 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 @@ -507,7 +507,7 @@ private theorem letter_insert_true eqToHom (congrArg (tensorPow A Z) (Nat.succ_add_eq_add_succ p m)) := by rw [tensor_split_last] - simp only [Category.assoc] + repeat' erw [Category.assoc] rw [concat_whisker_insert, insertTop_full, MonoidalCategory.associator_naturality_assoc, tensor_then_whiskerLeft_assoc, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagCarrier.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagCarrier.lean index c197c54f5e..c730554d7b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagCarrier.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagCarrier.lean @@ -71,7 +71,7 @@ theorem modMultiπ_single show (modMultiTriv A (modSlots_singleton A X)).inv ≫ (modMultiTriv A (modSlots_singleton A X)).hom ≫ (ρ_ X.X).hom = (ρ_ X.X).hom - rw [Iso.inv_hom_id_assoc] + 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 @@ -204,7 +204,7 @@ theorem zigContract_cond (((modTensorLegM A M M' ▷ modList A [M]) ≫ (α_ M.X M'.X (modList A [M])).hom) ≫ contract3Fold A p M) ≫ (modMultiSingle A M).hom := by - simp only [Category.assoc] + 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)) ≫ @@ -213,7 +213,7 @@ theorem zigContract_cond (((modTensorLegN A M M' ▷ modList A [M]) ≫ (α_ M.X M'.X (modList A [M])).hom) ≫ contract3Fold A p M) ≫ (modMultiSingle A M).hom := by - simp only [Category.assoc] + repeat' erw [Category.assoc] exact (window_contract3Fold_carrier A p (modTensorLegM A M M')).symm.trans ((aM.trans (hmid.trans aN.symm)).trans @@ -395,7 +395,7 @@ theorem zigComposite_eq_carrier rw [reassoc_of% s1, reassoc_of% s2, whiskerLeft_modMultiπ_concat_assoc, copairImage_eq, MonoidalCategory.comp_whiskerRight] - simp only [Category.assoc] + repeat' erw [Category.assoc] have hcore := pairInv_concat_contract3_single A p hp have hfin : (λ_ (M.X ⊗ 𝟙_ D)).inv ≫ ((η[A] ≫ c) ▷ (M.X ⊗ 𝟙_ D)) ≫ @@ -486,7 +486,7 @@ theorem contract3LFold_single ((α_ A M'.X (𝟙_ D)).inv ≫ (actLeft A M'.X ▷ (𝟙_ D))) ≫ (modMultiπ A [M'] ≫ (modMultiSingle A M').hom) := by - simp only [Category.assoc] + 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)) ≫ @@ -601,7 +601,7 @@ theorem zagContract_cond contract3LFold A p M') ≫ (modMultiSingle A M').hom := by rw [MonoidalCategory.whiskerLeft_comp] - simp only [Category.assoc] + 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))) ≫ @@ -612,7 +612,7 @@ theorem zagContract_cond contract3LFold A p M') ≫ (modMultiSingle A M').hom := by rw [MonoidalCategory.whiskerLeft_comp] - simp only [Category.assoc] + repeat' erw [Category.assoc] exact (window_contract3LFold_carrier A p (modTensorLegM A M M')).symm.trans ((aM.trans (hmid.trans aN.symm)).trans @@ -743,7 +743,7 @@ theorem pairInv_concat_contract3L_single ((ρ_ M'.X).hom ▷ (M.X ⊗ M'.X)) ≫ (α_ M'.X M.X M'.X).inv := by monoidal - simp only [Category.assoc] + 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') ≫ @@ -801,7 +801,7 @@ theorem zagComposite_eq_carrier simp only [zagComposite, Category.assoc] rw [reassoc_of% s1, reassoc_of% s2, copairImage_eq, MonoidalCategory.whiskerLeft_comp] - simp only [Category.assoc] + repeat' erw [Category.assoc] have hcore := pairInv_concat_contract3L_single A p hp have hfin : (ρ_ (M'.X ⊗ 𝟙_ D)).inv ≫ ((M'.X ⊗ 𝟙_ D) ◁ (η[A] ≫ c)) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharDecomp.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharDecomp.lean index 84f0e9bf8e..6b4740d876 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharDecomp.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharDecomp.lean @@ -155,7 +155,8 @@ private theorem character_eq_sum_nChar_aux {G : Type*} [Group G] [Fintype G] : have h2 : rhoS S₀ g (eTS.symm ⟨v, hv⟩) = (MonoidAlgebra.single g (1 : ℂ)) • eTS.symm ⟨v, hv⟩ := rhoS_apply S₀ g _ - rw [h1, map_smul, h2] + 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 @@ -187,7 +188,6 @@ private theorem character_eq_sum_nChar_aux {G : Type*} [Group G] [Fintype G] : congr 1 ext ⟨v, hv⟩ : 1 apply Subtype.ext - simp only [restrict_apply] 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)) = @@ -195,7 +195,6 @@ private theorem character_eq_sum_nChar_aux {G : Type*} [Group G] [Fintype G] : congr 1 ext ⟨v, hv⟩ : 1 apply Subtype.ext - simp only [restrict_apply] exact (rhoSub_val_eq ρ W g ⟨v, hv⟩).symm -- Assemble final result refine ⟨m' + 1, Fin.cons S₀ S', ?_, ?_⟩ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean index 8d8a418e9e..7095b00153 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean @@ -508,7 +508,7 @@ private theorem braid_ee (r : ℂ) (x y : (stdSuperPair k ℓ).even) : (Eq.trans (whisker_unit_even' (SuperVect.koszulBraiding (stdSuperPair k ℓ) (stdSuperPair k ℓ)) r _) - (by rw [SuperVect.koszul_ee])))) ?_ + (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) : @@ -1360,7 +1360,7 @@ private theorem braid_eo (r : ℂ) (x : (stdSuperPair k ℓ).even) (Eq.trans (whisker_unit_odd' (SuperVect.koszulBraiding (stdSuperPair k ℓ) (stdSuperPair k ℓ)) r _) - (by rw [SuperVect.koszul_eo])))) ?_ + (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) @@ -1409,7 +1409,7 @@ private theorem braid_oe (r : ℂ) (u : (stdSuperPair k ℓ).odd) (Eq.trans (whisker_unit_odd' (SuperVect.koszulBraiding (stdSuperPair k ℓ) (stdSuperPair k ℓ)) r _) - (by rw [SuperVect.koszul_oe])))) ?_ + (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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopExample.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopExample.lean index 95f400b37f..1117b0b1f8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopExample.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopExample.lean @@ -109,7 +109,7 @@ 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 <;> simp + 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⟩ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean index c5ce8fdc6f..839a95fb14 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean @@ -322,8 +322,11 @@ private theorem samePairing_of_matchEq {W : Fragment α} {F : EdgeSubset W} SamePairing κ₁ κ₂ := fun _ hδ => (pathMatch_matchEq heq hδ).symm --- Raised budget: membership in the symmetric difference is --- unfolded through the status sets on both sides. +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} @@ -331,9 +334,7 @@ private theorem mem_statusDiff {i : α} : i ∈ statusDiff κ κ' ↔ ((i ∈ highSet κ') ≠ (i ∈ highSet κ)) := by - unfold statusDiff - rw [mem_symmU, prop_ne_iff] - tauto + exact mem_symmU.trans (statusMembership_iff _ _) /-- Status differences transport across matching equality on the right. -/ From b8a23cf76af58affde9c007b8de27f323715c15b Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 21 Sep 2026 23:35:19 +0000 Subject: [PATCH 09/46] Port module pairings and supermodule shifts to current Mathlib --- .../RS/Classical/Deligne/ChainMulHet.lean | 4 +- .../RS/Classical/Deligne/FibreFunctor.lean | 4 +- .../RS/Classical/Deligne/FreeSlide.lean | 4 +- .../Classical/Deligne/GammaModuleFunctor.lean | 4 +- .../RS/Classical/Deligne/GammaPair.lean | 16 ++--- .../RS/Classical/Deligne/IdemCut.lean | 2 +- .../RS/Classical/Deligne/InitDatum.lean | 4 +- .../RS/Classical/Deligne/KernelPow.lean | 2 +- .../RS/Classical/Deligne/PairMul.lean | 18 +++--- .../RS/Classical/Deligne/PowPairing.lean | 58 ++++++++++--------- .../RS/Classical/Deligne/Rappel210Chain.lean | 2 +- .../RS/Classical/Deligne/SchurTransport.lean | 24 ++++---- .../RS/Classical/Deligne/SuperModAbelian.lean | 2 + .../Classical/Deligne/SuperModShiftUnit.lean | 44 +++++++------- .../Classical/SchurTheory/SquareGrowth.lean | 3 +- .../RS/Classical/Super/ColourTotal.lean | 4 +- 16 files changed, 102 insertions(+), 93 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulHet.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulHet.lean index eda1976705..a3b649c7a4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulHet.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulHet.lean @@ -141,7 +141,7 @@ theorem ι_chainMulHetStage [Category.{v} E] [MonoidalCategory E] (smallNatEquiv.functor.obj i)) ≫ chainMulHetStage B C F δB δF mu hδl j = mu i j ≫ chainColimitι F δF (i + 1 + j) - rw [chainMulHetStage, ι_preservesColimitIso_hom_assoc] + erw [chainMulHetStage, ι_preservesColimitIso_hom_assoc] exact colimit.ι_desc (chainMulHetCocone B C F δB δF mu hδl j) (smallNatEquiv.functor.obj i) @@ -235,7 +235,7 @@ theorem whiskerLeft_ι_chainColimitMulHet [Category.{v} E] [MonoidalCategory E] (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 - rw [chainColimitMulHet, ι_preservesColimitIso_hom_assoc] + erw [chainColimitMulHet, ι_preservesColimitIso_hom_assoc] exact colimit.ι_desc (chainMulHetTotalCocone B C F δB δC δF mu hδl hδr) (smallNatEquiv.functor.obj j) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFunctor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFunctor.lean index 3bba68b32f..548c2d0707 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFunctor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFunctor.lean @@ -47,14 +47,14 @@ noncomputable def fibreFunctor refine SuperCommAlgebra.Mod.Hom.ext ?_ ?_ <;> refine LinearMap.ext fun m => ?_ <;> · show m ≫ (freeModMap A (𝟙 X)).hom = m - rw [show (freeModMap A (𝟙 X)).hom = 𝟙 (fibreObj A X) from + 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 => ?_ <;> · show m ≫ (freeModMap A (f ≫ g)).hom = (m ≫ (freeModMap A f).hom) ≫ (freeModMap A g).hom - rw [show (freeModMap A (f ≫ 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSlide.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSlide.lean index 751386e8ef..5a46675472 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSlide.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSlide.lean @@ -140,7 +140,7 @@ theorem freeSlideTop_modPowπ freeSlideWin_modPowπ A V k 0 (rfl : k + 2 + 0 = k + 2) rw [modPowGlue, tensorPowConcat_zero, powCast_rfl, Category.id_comp] at hrel - simp only [Category.assoc] 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) ≫ @@ -150,7 +150,7 @@ theorem freeSlideTop_modPowπ refine (cancel_epi (ρ_ (tensorPow D (A ⊗ V) k ⊗ (A ⊗ V) ⊗ (A ⊗ V))).hom).mp ?_ exact Eq.trans (hnat _ _).symm (Eq.trans hrel (hnat _ _)) - rw [freeSlideTop, Category.assoc] + erw [freeSlideTop, Category.assoc] exact (whisker_eq _ hA).trans (Iso.hom_inv_id_assoc _ _) end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModuleFunctor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModuleFunctor.lean index 7af952e458..2f8653da38 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModuleFunctor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModuleFunctor.lean @@ -38,11 +38,11 @@ noncomputable def gammaModuleFunctor refine SuperCommAlgebra.Mod.Hom.ext ?_ ?_ <;> refine LinearMap.ext fun m => ?_ <;> · show m ≫ Mod.Hom.hom (𝟙 M) = m - rw [Mod.id_hom', Category.comp_id] + 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 => ?_ <;> · show m ≫ Mod.Hom.hom (f ≫ g) = (m ≫ f.hom) ≫ g.hom - rw [Mod.comp_hom', Category.assoc] + 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 index 81dd0eeea9..70503e7f4d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPair.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPair.lean @@ -888,14 +888,14 @@ theorem gammaPairEven_actEE ((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)) - rw [gammaPairEven_tmulEE, gammaPairEven_tmulEE] + erw [gammaPairEven_tmulEE, gammaPairEven_tmulEE] exact (gpair_act_eee M N x m n).symm · intro m n show 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)) - rw [gammaPairEven_tmulOO, gammaPairEven_tmulOO] + erw [gammaPairEven_tmulOO, gammaPairEven_tmulOO] exact (gpair_act_eoo L M N x m n).symm exact LinearMap.congr_fun key t @@ -926,14 +926,14 @@ theorem gammaPairOdd_actEO ((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)) - rw [gammaPairOdd_tmulEO, gammaPairOdd_tmulEO] + erw [gammaPairOdd_tmulEO, gammaPairOdd_tmulEO] exact (gpair_act_eeo L M N x m n).symm · intro m n show 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)) - rw [gammaPairOdd_tmulOE, gammaPairOdd_tmulOE] + erw [gammaPairOdd_tmulOE, gammaPairOdd_tmulOE] exact (gpair_act_eoe L M N x m n).symm exact LinearMap.congr_fun key t @@ -965,14 +965,14 @@ theorem gammaPairOdd_actOE ((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)) - rw [gammaPairOdd_tmulOE, gammaPairEven_tmulEE] + erw [gammaPairOdd_tmulOE, gammaPairEven_tmulEE] exact (gpair_act_oee L M N u m n).symm · intro m n show 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)) - rw [gammaPairOdd_tmulEO, gammaPairEven_tmulOO] + erw [gammaPairOdd_tmulEO, gammaPairEven_tmulOO] exact (gpair_act_ooo L M N u m n).symm exact LinearMap.congr_fun key t @@ -1004,14 +1004,14 @@ theorem gammaPairEven_actOO ((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)) - rw [gammaPairEven_tmulOO, gammaPairOdd_tmulEO] + erw [gammaPairEven_tmulOO, gammaPairOdd_tmulEO] exact (gpair_act_oeo L M N u m n).symm · intro m n show 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)) - rw [gammaPairEven_tmulEE, gammaPairOdd_tmulOE] + erw [gammaPairEven_tmulEE, gammaPairOdd_tmulOE] exact (gpair_act_ooe L M N u m n).symm exact LinearMap.congr_fun key t diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean index d3eb54a223..b27526d3d7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean @@ -461,7 +461,7 @@ theorem modPowGlue_natural [Category.{v} D] [MonoidalCategory D] {X : D} {Y : D} ((tensorPowMap f a ⊗ₘ (f ⊗ₘ f)) ⊗ₘ tensorPowMap f b) ≫ modPowGlue Y a b = modPowGlue X a b ≫ tensorPowMap f (a + 2 + b) := by - rw [modPowGlue, modPowGlue, ← Category.assoc, tensor_comp_whisker, + erw [modPowGlue, modPowGlue, ← Category.assoc, tensor_comp_whisker, MonoidalCategory.associator_inv_naturality, ← whisker_comp_tensor, Category.assoc, Category.assoc] exact congrArg (CategoryStruct.comp _) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitDatum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitDatum.lean index cfebc6ca99..3971039002 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitDatum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitDatum.lean @@ -130,7 +130,7 @@ theorem unitBaseDatum_zigzag rw [show η[𝟙_ D] ≫ (unitBaseDatum X Y).copair = η_ X Y ≫ (modTensorUnitBase (unitMod X) (unitMod Y)).inv from Category.id_comp _] - rw [MonoidalCategory.comp_whiskerRight, Category.assoc] + 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 ≫ @@ -171,7 +171,7 @@ theorem unitBaseDatum_zigzag rw [show η[𝟙_ D] ≫ (unitBaseDatum X Y).copair = η_ X Y ≫ (modTensorUnitBase (unitMod X) (unitMod Y)).inv from Category.id_comp _] - rw [MonoidalCategory.whiskerLeft_comp, Category.assoc] + 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 ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KernelPow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KernelPow.lean index 778ca0e1a3..e629b688d5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KernelPow.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KernelPow.lean @@ -285,7 +285,7 @@ theorem wordMap_append (wordMap f g (a + b) (wordAppend wa (wb ∘ Fin.castSucc)) ⊗ₘ letterMap f g (wb (Fin.last b))) hsplit).trans ?_ - rw [Category.assoc] + 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))) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairMul.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairMul.lean index 39f8b9bef4..ff3a0fa7ab 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairMul.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairMul.lean @@ -174,8 +174,8 @@ theorem interchange_legM have hcov' := congrArg (fun t => t ≫ modTensorπ A (modTensorMod A N₁ P₁) (modTensorMod A N₂ P₂)) hcov - simp only [Category.assoc] at hcov' - conv_rhs => rw [hcov', midArrange] + 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)) ?_ @@ -225,7 +225,7 @@ theorem interchange_legN conv_lhs => rw [modTensorLegN, rawInterchangeπ, rawInterchange, comp_whiskerRight, Category.assoc, reassoc_of% h1] - conv_lhs => rw [reassoc_of% hml (actLeft A N₂.X ▷ P₂.X) + 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₂) @@ -266,10 +266,10 @@ theorem interchange_legN ((actLeft A N₂.X ▷ P₂.X) ≫ modTensorπ A N₂ P₂)) ≫ modTensorπ A (modTensorMod A N₁ P₁) (modTensorMod A N₂ P₂) := by - rw [← Category.assoc, hcov] + erw [← Category.assoc, hcov] exact (Category.assoc _ _ _).trans (congrArg (CategoryStruct.comp _) (Category.assoc _ _ _)) - conv_rhs => rw [hcov', midArrange] + 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₂) @@ -383,8 +383,8 @@ theorem interchange_legMP have hcov' := congrArg (fun t => t ≫ modTensorπ A (modTensorMod A N₁ P₁) (modTensorMod A N₂ P₂)) hcov - simp only [Category.assoc] at hcov' - conv_rhs => rw [hcov', midArrangeP] + 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)) ?_ @@ -497,7 +497,7 @@ theorem interchange_legNP conv_lhs => rw [modTensorLegN, rawInterchangeπ, rawInterchange, MonoidalCategory.whiskerLeft_comp, Category.assoc, reassoc_of% h1] - conv_lhs => rw [reassoc_of% hml (N₂.X ◁ actLeft A P₂.X) + 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₂) @@ -538,7 +538,7 @@ theorem interchange_legNP ((actLeft A N₂.X ▷ P₂.X) ≫ modTensorπ A N₂ P₂)) ≫ modTensorπ A (modTensorMod A N₁ P₁) (modTensorMod A N₂ P₂) := by - rw [← Category.assoc, hcov] + erw [← Category.assoc, hcov] exact (Category.assoc _ _ _).trans (congrArg (CategoryStruct.comp _) (Category.assoc _ _ _)) conv_rhs => rw [hcov', midArrangeP] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean index e1421bba84..30af3af306 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean @@ -375,7 +375,7 @@ private theorem leg_step_snd_eq [Category.{v} D] [MonoidalCategory D] (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 = _ - simp only [Category.assoc] + 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 ▷ @@ -918,7 +918,7 @@ private theorem leg_head_snd_eq [Category.{v} D] [MonoidalCategory D] (A : D) (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) = _ - simp only [Category.assoc] + 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 @@ -1147,7 +1147,9 @@ theorem rawPair_rel_fst_top tensorPow D M.X (a + 1 + 1)) ≫ rawPair A M M' d (a + 1 + 1) rw [rawPair_succ_step] - simp only [comp_whiskerRight, Category.assoc, cancel_epi] + simp only [comp_whiskerRight] + repeat' erw [Category.assoc] + rw [cancel_epi] show ((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 ▷ @@ -1189,9 +1191,9 @@ private theorem leg_step_eq (α_ ((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) = _ - rw [associator_inv_naturality_left_assoc, + erw [associator_inv_naturality_left_assoc, associator_inv_naturality_left_assoc] - simp only [comp_whiskerRight] + conv_rhs => erw [comp_whiskerRight, comp_whiskerRight] rfl /-- **The first slot relations of the power pairing**: at every @@ -1232,7 +1234,9 @@ theorem rawPair_rel_fst (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, Category.assoc, cancel_epi] + simp only [comp_whiskerRight] + repeat' erw [Category.assoc] + rw [cancel_epi] rw [rawPair_succ_step] show ((modPowLegM A M'.X a b ▷ M'.X) ▷ tensorPow D M.X (a + 2 + b + 1)) ≫ @@ -1266,7 +1270,7 @@ theorem rawPair_rel_snd | 0, m, h => by subst h rw [rawPair_cast A M M' d (by omega : 0 + 2 + b = b + 1 + 1)] - rw [rawPair_succ_step, rawPair_succ_step, + 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] @@ -1352,15 +1356,15 @@ theorem rawPair_rel_snd 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 - rw [← MonoidalCategory.whiskerLeft_comp_assoc, - ← MonoidalCategory.whiskerLeft_comp_assoc] - conv_lhs => simp only [Category.assoc] - rw [leg_step_snd_eq w a b] - rw [MonoidalCategory.whiskerLeft_comp, - MonoidalCategory.whiskerLeft_comp, - MonoidalCategory.whiskerLeft_comp] - simp only [Category.assoc] - rfl + 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 _) ?_ @@ -1481,10 +1485,10 @@ theorem rawPair_actTail rw [braiding_tensorUnit_right] monoidal rw [rawPair_succ_step] - conv_lhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc, + conv_lhs => erw [← MonoidalCategory.whiskerLeft_comp_assoc, hact] - conv_lhs => simp only [MonoidalCategory.whiskerLeft_comp, - Category.assoc] + conv_lhs => simp only [MonoidalCategory.whiskerLeft_comp] + conv_lhs => erw [Category.assoc, Category.assoc] show ((tensorPow D M'.X 0 ⊗ M'.X) ◁ (A ◁ (powPeel M.X 0).hom)) ≫ ((tensorPow D M'.X 0 ⊗ M'.X) ◁ @@ -1496,7 +1500,7 @@ theorem rawPair_actTail (tensorPow D M'.X 0 ⊗ M'.X) (α_ A M.X (tensorPow D M.X 0)).inv] rw [pairStep_actHead] - conv_rhs => rw [comp_whiskerRight] + conv_rhs => erw [comp_whiskerRight] conv_rhs => simp only [Category.assoc] conv_rhs => rw [← associator_inv_naturality_middle_assoc, ← MonoidalCategory.whiskerLeft_comp_assoc, @@ -1507,17 +1511,17 @@ theorem rawPair_actTail (A ◁ (powPeel M.X 0).hom)) = ((tensorPow D M'.X 0 ⊗ M'.X) ◁ (A ◁ (powPeel M.X 0).hom)) from rfl] - conv_rhs => simp only [Category.assoc] + 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 => rw [← MonoidalCategory.whiskerLeft_comp_assoc, + conv_lhs => erw [← MonoidalCategory.whiskerLeft_comp_assoc, powTailAct_peel A] - conv_lhs => simp only [MonoidalCategory.whiskerLeft_comp, - Category.assoc] + conv_lhs => simp only [MonoidalCategory.whiskerLeft_comp] + conv_lhs => erw [Category.assoc, Category.assoc] show ((tensorPow D M'.X (n + 1) ⊗ M'.X) ◁ (A ◁ (powPeel M.X (n + 1)).hom)) ≫ ((tensorPow D M'.X (n + 1) ⊗ M'.X) ◁ @@ -1528,7 +1532,7 @@ theorem rawPair_actTail rw [pairStep_postcomp] rw [rawPair_actTail A M M' d n] rw [pairStep_ext] - conv_rhs => rw [comp_whiskerRight] + conv_rhs => erw [comp_whiskerRight] conv_rhs => simp only [Category.assoc] conv_rhs => rw [← associator_inv_naturality_middle_assoc, ← MonoidalCategory.whiskerLeft_comp_assoc, @@ -1539,7 +1543,7 @@ theorem rawPair_actTail (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 => simp only [Category.assoc] + conv_rhs => erw [Category.assoc] refine congrArg (CategoryStruct.comp ((tensorPow D M'.X (n + 1) ⊗ M'.X) ◁ (A ◁ (powPeel M.X (n + 1)).hom))) ?_ @@ -1831,7 +1835,7 @@ theorem pairPow_middle_cond rawPair A M M' d (n + 1) := by intro Y Y' f g refine (hstage1 (f ≫ g)).trans ?_ - rw [comp_whiskerRight, Category.assoc] + erw [comp_whiskerRight, Category.assoc] rfl refine Eq.trans (congrArg (fun t => (α_ (tensorPow D M'.X (n + 1)) A diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Chain.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Chain.lean index 00c0669a36..332c8efff3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Chain.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Chain.lean @@ -211,7 +211,7 @@ theorem splitSeed_mu_right (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 - rw [hk, Category.comp_id, Iso.hom_inv_id_assoc] + 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean index 92229f7a2d..5620e41b67 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean @@ -89,8 +89,7 @@ lemma dayUnitIso_hom_app_nu [SmallCategory D] [MonoidalCategory D] : (coyonedaDayCorepresentableBy (𝟙_ D)) = dayUnitIso D from rfl] at h refine h.trans ?_ - dsimp [coyonedaDayCorepresentableBy] - rw [coyonedaEquiv_apply] + change coyonedaEquiv (𝟙 (coyoneda.obj (op (𝟙_ D)))) = 𝟙 (𝟙_ D) rfl /-- The inverse of the Day unit comparison carries the identity to @@ -177,13 +176,14 @@ lemma dayCoyonedaIso_hom_leftUnitor [SmallCategory D] [MonoidalCategory D] DayFunctor.mk (coyoneda.obj (op (𝟙_ D ⊗ a))) ⟶ DayFunctor.mk (coyoneda.obj (op a))) := by apply (dayCoyonedaCorepresentableBy (𝟙_ D) a).homEquiv.injective - rw [(dayCoyonedaCorepresentableBy (𝟙_ D) a).homEquiv_comp, - (dayCoyonedaCorepresentableBy (𝟙_ D) a).homEquiv_comp, - dayCoyonedaCorepresentableBy_homEquiv_iso, - dayEvaluation_map_apply, dayEvaluation_map_apply, - dayCoyonedaCorepresentableBy_homEquiv_apply, - whiskerRight_dayUnitIso_inv_app_unitElt, - day_leftUnitor_hom_app_eta] + 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] show 𝟙 a ≫ (λ_ a).inv = (λ_ a).inv ≫ 𝟙 (𝟙_ D ⊗ a) rw [Category.id_comp, Category.comp_id] rw [← aux, ← Category.assoc, ← MonoidalCategory.comp_whiskerRight, @@ -242,7 +242,7 @@ lemma dayYonedaIso_hom_leftUnitor [SmallCategory C] [MonoidalCategory C] (dayMkIso (Coyoneda.objOpOp x).symm).hom) ≫ ((dayUnitIso Cᵒᵖ).hom ▷ DayFunctor.mk (coyoneda.obj (op (op x)))) := by - rw [← MonoidalCategory.tensorHom_id, + erw [← MonoidalCategory.tensorHom_id, MonoidalCategory.tensorHom_comp_tensorHom, Category.id_comp, Category.assoc, comp_dayMkIso_hom_symm_hom, MonoidalCategory.tensorHom_def'] @@ -287,7 +287,7 @@ lemma indOf_leftUnitor_hom [SmallCategory C] [MonoidalCategory C] (indToDay (C := C)).obj (indOf.obj X)) ≫ ((indToDayIndOfIso (𝟙_ C)).hom ⊗ₘ (indToDayIndOfIso X).hom) = DayFunctor.mk (yoneda.obj (𝟙_ C)) ◁ (indToDayIndOfIso X).hom := by - rw [← MonoidalCategory.tensorHom_id, + erw [← MonoidalCategory.tensorHom_id, MonoidalCategory.tensorHom_comp_tensorHom, Iso.inv_hom_id, Category.id_comp, MonoidalCategory.id_tensorHom] have hB : ((dayUnitIso Cᵒᵖ).hom ▷ @@ -468,7 +468,7 @@ theorem schurKilled_indOf_iff show 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] - rfl + /-- `RS.schurKilled_indOf_iff`, instantiated at the scalar unit of a category whose unit endomorphisms are exactly the scalars. -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModAbelian.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModAbelian.lean index 88898c8211..1ce29420d4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModAbelian.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModAbelian.lean @@ -71,9 +71,11 @@ def actRestrict [AddCommGroup A] [Module ℂ A] [AddCommGroup E] [Module ℂ E] 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShiftUnit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShiftUnit.lean index fef1ef3880..cd6636845e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShiftUnit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShiftUnit.lean @@ -87,44 +87,44 @@ def shiftUnitData : TensorData (shift S.unitMod) M (shift M) where foe := M.actEE hee := fun b m n => by show M.actOE (S.mulEO b m) n = M.actOE m (M.actEE b n) - rw [← M.assoc_oee, ← S.comm_eo] + erw [← M.assoc_oee, ← S.comm_eo] hoo := fun b m n => by show -M.actEO (S.mulEE b m) n = -M.actEO m (M.actEO b n) - rw [M.assoc_eeo, M.actEO_actEO_comm] + erw [M.assoc_eeo, M.actEO_actEO_comm] hoeo := fun c m n => by show -M.actEO (S.mulOO c m) n = M.actOE m (M.actOO c n) - rw [M.assoc_ooo, M.actOE_actOO_neg, neg_neg] + erw [M.assoc_ooo, M.actOE_actOO_neg, neg_neg] hooe := fun c m n => by show M.actOE (S.mulOE c m) n = -(-(M.actEO m (M.actOE c n))) - rw [neg_neg, M.assoc_oee, M.actEO_actOE] + erw [neg_neg, M.assoc_oee, M.actEO_actOE] heeo := fun b m n => by show -M.actOO (S.mulEO b m) n = -M.actOO m (M.actEO b n) - rw [M.assoc_eoo, M.actEE_actOO] + erw [M.assoc_eoo, M.actEE_actOO] heoe := fun b m n => by show M.actEE (S.mulEE b m) n = M.actEE m (M.actEE b n) - rw [M.assoc_eee, M.actEE_actEE_comm] + erw [M.assoc_eee, M.actEE_actEE_comm] hoee := fun c m n => by show M.actEE (S.mulOO c m) n = -(M.actOO m (M.actOE c n)) - rw [M.assoc_ooe, M.actOO_actOE_neg] + erw [M.assoc_ooe, M.actOO_actOE_neg] hooo := fun c m n => by show -M.actOO (S.mulOE c m) n = -(M.actEE m (M.actOO c n)) - rw [M.assoc_oeo, M.actEE_actOO] + erw [M.assoc_oeo, M.actEE_actOO] aee := fun a m n => M.assoc_eoe a m n aoo := fun a m n => by show -M.actEO (S.mulEE a m) n = M.actEO a (-(M.actEO m n)) - rw [M.assoc_eeo, map_neg] + erw [M.assoc_eeo, map_neg] aeo := fun a m n => by show -M.actOO (S.mulEO a m) n = M.actEE a (-(M.actOO m n)) - rw [M.assoc_eoo, map_neg] + 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 show -M.actOO (S.mulOE c m) n = M.actOO c (-(M.actEO m n)) - rw [M.assoc_oeo, map_neg] + erw [M.assoc_oeo, map_neg] ceo := fun c m n => by show -M.actEO (S.mulOO c m) n = M.actOE c (-(M.actOO m n)) - rw [M.assoc_ooo, map_neg] + erw [M.assoc_ooo, map_neg] coe := fun c m n => M.assoc_oee c m n /-! ## The structure maps -/ @@ -169,22 +169,26 @@ noncomputable def shiftUnitInv : show -(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)) - rw [map_neg, actEE_tmulOO, tmulOO_balanced_eoo] + erw [map_neg, actEE_tmulOO, tmulOO_balanced_eoo] map_actEO x m := by show 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) - rw [actEO_tmulOE, tmulOE_balanced_eoe] + 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 show 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, actOE_tmulOO, tmulEO_balanced_ooo, neg_neg] + 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 show -(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) - rw [actOO_tmulOE, tmulEE_balanced_ooe] + erw [actOO_tmulOE, tmulEE_balanced_ooe] /-- The inverse in even degree. -/ @[simp] theorem shiftUnitInv_evenMap (m : M.odd) : @@ -208,19 +212,19 @@ noncomputable def shiftUnitTensor : refine hom_ext (fun (v : S.odd) m => ?_) (fun (x : S.even) m => ?_) (fun (v : S.odd) m => ?_) (fun (x : S.even) m => ?_) - · rw [comp_evenMap, LinearMap.comp_apply, + · erw [comp_evenMap, LinearMap.comp_apply, shiftUnitHom_evenMap_tmulEE, shiftUnitInv_evenMap, id_evenMap, LinearMap.id_coe, id_eq, ← tmulEE_balanced_ooe, shiftUnitMod_actOO_one] - · rw [comp_evenMap, LinearMap.comp_apply, + · 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] - · rw [comp_oddMap, LinearMap.comp_apply, + · 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] - · rw [comp_oddMap, LinearMap.comp_apply, + · erw [comp_oddMap, LinearMap.comp_apply, shiftUnitHom_oddMap_tmulOE, shiftUnitInv_oddMap, id_oddMap, LinearMap.id_coe, id_eq, ← tmulOE_balanced_eoe, shiftUnitMod_actEO_one] diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowth.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowth.lean index 55f7a907be..a20d9ec113 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowth.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowth.lean @@ -64,8 +64,7 @@ theorem square_D_le (s : ℕ) (_hs : 1 ≤ s) : ((2 * s) ^ s * (((squareDiagram s).rowLens.length - 1) - (i : ℕ)).factorial) := by - refine Finset.prod_le_prod (fun _ _ => Nat.zero_le _) - (fun i _ => ?_) + refine Finset.prod_le_prod (fun i _ => ?_) rw [eStair_square s i] have hi := i.isLt rw [show ((squareDiagram s).rowLens.length - 1) - diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourTotal.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourTotal.lean index 0d0c4ddc82..dd07d877f3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourTotal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourTotal.lean @@ -77,12 +77,12 @@ theorem colourTotalEquiv_modelPermMap · rw [dif_pos hc] change (colourSwapWord k ℓ (adjWord σ)).evenMap (fun a => v a.val) ⟨c, hc⟩ = _ - rw [colourSwapWord_evenMap, wordSign_eq_oddInversions, + erw [colourSwapWord_evenMap, wordSign_eq_oddInversions, wordPerm_adjWord] · rw [dif_neg hc] change (colourSwapWord k ℓ (adjWord σ)).oddMap (fun a => v a.val) ⟨c, hc⟩ = _ - rw [colourSwapWord_oddMap, wordSign_eq_oddInversions, + erw [colourSwapWord_oddMap, wordSign_eq_oddInversions, wordPerm_adjWord] end From 5b52430c732f963ea4d6b0eb45801e6187762c35 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 21 Sep 2026 23:40:38 +0000 Subject: [PATCH 10/46] Update pairing permutations and Day functor coherence --- .../RS/Classical/Deligne/ChainMul.lean | 5 +++-- .../RS/Classical/Deligne/ExactFromShort.lean | 6 +++--- .../RS/Classical/Deligne/FreeModAdjoint.lean | 2 +- .../RS/Classical/Deligne/FreeModTensor.lean | 2 +- .../RS/Classical/Deligne/GammaPairAdd.lean | 4 ++-- .../RS/Classical/Deligne/GammaPairNat.lean | 12 +++++++---- .../RS/Classical/Deligne/IndOfMonoidal.lean | 15 ++++++++------ .../RS/Classical/Deligne/ModPowDescent.lean | 2 +- .../RS/Classical/Deligne/PairPerm.lean | 20 +++++++++---------- .../RS/Classical/Deligne/RegularSum.lean | 13 ++++++------ .../RS/Classical/Deligne/SplitComplement.lean | 14 ++++++------- .../Classical/Interfaces/TotalDimension.lean | 7 ++++--- .../RS/Classical/SchurTheory/PairingPos.lean | 1 + 13 files changed, 56 insertions(+), 47 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMul.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMul.lean index 749a727170..5cb1e3f9c1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMul.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMul.lean @@ -194,7 +194,8 @@ theorem tensorHom_π_chainMul (symPowMod A M.X (m + 1 + n)) := modTensorπ_map A (symMulMod A M'.X m n) (symMulMod A M.X m n) - show tensorμ (symPow A M'.X (m + 1)) (symPow A M.X (m + 1)) + 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)) ≫ @@ -205,7 +206,7 @@ theorem tensorHom_π_chainMul (symMulMod A M.X m n) = _ refine congrArg (CategoryStruct.comp _) ?_ refine (congrArg (CategoryStruct.comp _) h6).trans ?_ - rw [show (symMulMod A M'.X m n).hom = symMulDesc A M'.X m n + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ExactFromShort.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ExactFromShort.lean index b9fd8fa509..a164e5df82 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ExactFromShort.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ExactFromShort.lean @@ -40,7 +40,7 @@ theorem preservesFiniteLimits_of_shortExact Limits.PreservesFiniteLimits F := have hboth : Limits.PreservesFiniteLimits F ∧ Limits.PreservesFiniteColimits F := - ((CategoryTheory.Functor.exact_tfae F).out 0 3).mp h + ((CategoryTheory.Functor.exact_tfae F).out 1 4).mp h hboth.1 /-- **A functor carrying short exact sequences to short exact @@ -54,7 +54,7 @@ theorem preservesFiniteColimits_of_shortExact Limits.PreservesFiniteColimits F := have hboth : Limits.PreservesFiniteLimits F ∧ Limits.PreservesFiniteColimits F := - ((CategoryTheory.Functor.exact_tfae F).out 0 3).mp h + ((CategoryTheory.Functor.exact_tfae F).out 1 4).mp h hboth.2 /-- **A functor carrying short exact sequences to short exact @@ -67,7 +67,7 @@ theorem preservesHomology_of_shortExact (h : ∀ (S : CategoryTheory.ShortComplex C), S.ShortExact → (S.map F).ShortExact) : F.PreservesHomology := - ((CategoryTheory.Functor.exact_tfae F).out 0 2).mp h + ((CategoryTheory.Functor.exact_tfae F).out 1 3).mp h end General diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModAdjoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModAdjoint.lean index 3eb9145170..c024821ac8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModAdjoint.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModAdjoint.lean @@ -216,7 +216,7 @@ noncomputable def freeModAdjunction apply Mod.Hom.ext show A ◁ (u ≫ g) ≫ actLeft A M.X = A ◁ u ≫ A ◁ g ≫ actLeft A M.X - rw [MonoidalCategory.whiskerLeft_comp, Category.assoc] + 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 } diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModTensor.lean index 5674fbaef5..b7b29cb3d9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModTensor.lean @@ -375,7 +375,7 @@ theorem freeModTensorIso_gpair gpair (M := freeMod R V) (N := freeMod R W) m n ≫ (freeModTensorIso R V W).hom.hom = (m ⊗ₘ n) ≫ freeModShuffle R V W := by - rw [gpair_def, Category.assoc] + erw [gpair_def, Category.assoc] exact whisker_eq _ (modTensorπ_freeModTensorIso R V W) end Iso diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairAdd.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairAdd.lean index 71b2fb299d..d3f25900dc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairAdd.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairAdd.lean @@ -131,10 +131,10 @@ theorem sum_gammaModuleFunctor_map refine LinearMap.ext fun m => ?_ · rw [SuperCommAlgebra.Mod.sum_evenMap_apply] show ∑ i ∈ s, m ≫ (g i).hom = m - rw [← Preadditive.comp_sum, h, Category.comp_id] + erw [← Preadditive.comp_sum, h, Category.comp_id] · rw [SuperCommAlgebra.Mod.sum_oddMap_apply] show ∑ i ∈ s, m ≫ (g i).hom = m - rw [← Preadditive.comp_sum, h, Category.comp_id] + erw [← Preadditive.comp_sum, h, Category.comp_id] end Realize diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairNat.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairNat.lean index b422794a78..c4c39271b2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairNat.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairNat.lean @@ -245,16 +245,20 @@ theorem gammaPairComparison_naturality_aux 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, gammaPairEven_tmulEE] + 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, gammaPairEven_tmulOO] + 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, gammaPairOdd_tmulEO] + 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, gammaPairOdd_tmulOE] + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfMonoidal.lean index bb49661752..837e031d5f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfMonoidal.lean @@ -135,12 +135,15 @@ lemma dayCoyonedaIso_hom_rightUnitor [SmallCategory D] [MonoidalCategory D] (ρ_ (DayFunctor.mk (coyoneda.obj (op a)) : D ⊛⥤ Type v)).hom := by apply (dayCoyonedaCorepresentableBy a (𝟙_ D)).homEquiv.injective - rw [(dayCoyonedaCorepresentableBy a (𝟙_ D)).homEquiv_comp, - dayCoyonedaCorepresentableBy_homEquiv_iso, dayEvaluation_map_apply, - dayCoyonedaCorepresentableBy_homEquiv_apply, comp_natTrans, - NatTrans.comp_app, CategoryTheory.comp_apply, - whiskerLeft_dayUnitIso_inv_app_unitElt, - dayRightUnitor_hom_app_unitElt] + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescent.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescent.lean index ad0d32221e..aa0254d848 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescent.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescent.lean @@ -83,7 +83,7 @@ theorem sandwichTower_retract rw [← modTensorMap_comp, Category.comp_id] have hcarrier : ik ≫ rk = 𝟙 M := hk rw [hcarrier, modTensorMap_id] - rw [Category.assoc] + erw [Category.assoc] refine Eq.trans (whisker_eq _ (Category.assoc _ _ _).symm) ?_ refine Eq.trans (whisker_eq _ (eq_whisker hmid _)) ?_ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairPerm.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairPerm.lean index 00a56460cc..d04f95042a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairPerm.lean @@ -737,9 +737,10 @@ private theorem rawPair_topSwap (M.X ◁ (powPeel M.X n).hom))) ≫ pairStep A M M' d (pairStep A M M' d (rawPair A M M' d n)) := by - rw [rawPair_succ_step, rawPair_succ_step, - ← pairStep_postcomp, MonoidalCategory.whiskerLeft_comp] - simp only [Category.assoc] + 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 := @@ -767,11 +768,10 @@ private theorem rawPair_topSwap 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 - rw [hpair, hts, ← whisker_exchange_assoc, + erw [hpair, hts, ← whisker_exchange_assoc, ← MonoidalCategory.whiskerLeft_comp_assoc, hlow] - conv_rhs => rw [MonoidalCategory.whiskerLeft_comp] - simp only [Category.assoc] - rw [hdbl] + 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 @@ -874,8 +874,8 @@ private theorem rawPair_swap rw [hswL, permMor_extPerm] exact pairStep_precomp A M M' d _ _ rw [rawPair_succ_step] - rw [← whisker_exchange_assoc, hstep] - rw [← MonoidalCategory.whiskerLeft_comp_assoc, + 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] @@ -1027,13 +1027,11 @@ theorem symPowIdem_pairPow modPowPerm (A := A) (X := M'.X) n σ := by rw [symPowIdem, symmetriser, map_smul, map_sum] simp only [modPowAlg_single] - rfl 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] - rfl rw [hexpL, hexpR, MonoidalLinear.smul_whiskerRight, MonoidalLinear.whiskerLeft_smul, Linear.smul_comp, Linear.smul_comp] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean index 36e4cef89d..bf37bbf98a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean @@ -367,8 +367,9 @@ theorem cycleType_permCast {m n : ℕ} (h : m = n) /-- `symCast` at a reflexive inequality is the identity. -/ theorem symCast_le_refl {n : ℕ} (h : n ≤ n) (x : SymGroupAlgebra n) : symCast h x = x := by - show Finsupp.mapDomain - (⇑(Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h))) x = x + 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 σ @@ -389,7 +390,7 @@ theorem symCast_le_refl {n : ℕ} (h : n ≤ n) (x : SymGroupAlgebra n) : 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 g = x ((permCast h).symm g) := by + (symCast (le_of_eq h) x).coeff g = x.coeff ((permCast h).symm g) := by subst h rw [symCast_le_refl, permCast_rfl] rfl @@ -610,8 +611,8 @@ theorem classFun_eq_zero_of_cycleProd {n : ℕ} rw [smul_eq_C_mul, map_mul, eval_C, eval_cycExp]] exact hvan t intro π₀ - have hcoeff := congrArg (coeff (cycExp π₀)) hp0 - rw [hp, coeff_sum, coeff_zero] at hcoeff + 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 @@ -1124,7 +1125,7 @@ theorem shape_e_coeff_one (P : SchurPackage.{u}) {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 - show symCast (le_of_eq μ.prop) (P.e μ.val) 1 = P.e μ.val 1 + 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 := diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitComplement.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitComplement.lean index 7174a5f58e..ff87ad18ad 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitComplement.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitComplement.lean @@ -342,7 +342,7 @@ noncomputable def splitDecomp inv := biprod.desc (splitCoeval A B φ w d hw) (kernel.ι (splitIdem A B φ v w d hv hw)) hom_inv_id := by - rw [biprod.lift_desc, + 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 = @@ -350,7 +350,7 @@ noncomputable def splitDecomp rw [add_sub_cancel] inv_hom_id := by apply biprod.hom_ext' - · rw [biprod.inl_desc_assoc, Category.comp_id] + · 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δ] @@ -371,23 +371,23 @@ noncomputable def splitDecomp (Category.assoc _ _ _).symm] rw [splitCoeval_splitEval A B φ v w d hv hw p hp hδ, Category.id_comp, sub_self] - · rw [biprod.inr_desc_assoc, Category.comp_id] + · erw [biprod.inr_desc_assoc, Category.comp_id] apply biprod.hom_ext - · rw [Category.assoc, biprod.lift_fst, biprod.inr_fst] + · erw [Category.assoc, biprod.lift_fst, biprod.inr_fst] haveI : 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 ?_ - rw [Limits.zero_comp, Category.assoc] + erw [Limits.zero_comp, Category.assoc] exact kernel.condition _ - · rw [Category.assoc, biprod.lift_snd, biprod.inr_snd] + · 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δ)) ?_ - rw [Preadditive.comp_sub, Category.comp_id] + 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 _ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/TotalDimension.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/TotalDimension.lean index d36b397a24..44c7f122f2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/TotalDimension.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/TotalDimension.lean @@ -75,9 +75,10 @@ theorem stdModel_pow_le_connectionRank {R k ℓ : ℕ} ψ.toMonoidHom.comp (MonoidAlgebra.of ℂ _) have hρ : ρ.asAlgebraHom = ψ := by apply MonoidAlgebra.algHom_ext - intro σ - rw [Representation.asAlgebraHom_single, one_smul] - rfl + · 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ρ] diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean index 9c958d5f80..bcfa39c2e2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean @@ -240,6 +240,7 @@ private theorem coeff_det_jtMat_mul {k : ℕ} 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) · rw [if_pos hp, if_pos hp] · rw [if_neg hp, if_neg hp, zero_mul, MvPolynomial.coeff_zero] + rfl -- The main algebraic reduction open scoped Classical in From 327660b43d2480300be3c2e59d3929f75408c2db Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 21 Sep 2026 23:46:12 +0000 Subject: [PATCH 11/46] Repair tensor associators and fibre functor support proofs --- .../RegtsSevenster/RS/Assembly/Blueprint.lean | 2 +- .../RS/Classical/Deligne/ChainDelta.lean | 2 +- .../RS/Classical/Deligne/CharSplit.lean | 4 +-- .../RS/Classical/Deligne/FibreExact.lean | 2 +- .../RS/Classical/Deligne/FibreFaithful.lean | 4 +-- .../RS/Classical/Deligne/FibreMu.lean | 8 ++--- .../RS/Classical/Deligne/FreePowDesc.lean | 11 +++--- .../RS/Classical/Deligne/FreeSummand.lean | 16 ++++++++- .../Classical/Deligne/GammaPairRetract.lean | 2 +- .../RS/Classical/Deligne/IndSchurKilled.lean | 1 - .../RS/Classical/Deligne/ModAssoc.lean | 36 +++++++++++-------- .../Classical/Deligne/SplitExtractDual.lean | 14 ++++---- 12 files changed, 61 insertions(+), 41 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean b/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean index fc03fe6153..6528be520d 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean @@ -730,7 +730,7 @@ turns the sum into Definition 5. /- 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainDelta.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainDelta.lean index f5651cabea..b8dc166fb3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainDelta.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainDelta.lean @@ -55,7 +55,7 @@ theorem modPowAct_modPowOne apply modPow_whiskerLeft_hom_ext A X A 1 have hπ : modPowπ A X 1 ≫ (modPowOne A X).hom = (λ_ X).hom := by - rw [modPowOne, Iso.trans_hom, ← Category.assoc] + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CharSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CharSplit.lean index 948299b910..ddc8cc9e13 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CharSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CharSplit.lean @@ -186,8 +186,8 @@ theorem shape_e_coeff (P : SchurPackage.{u}) {n : ℕ} (μ : Shape n) jtChar μ.val (permCast μ.prop.symm π) := by have h1 : (Shape.e P μ).coeff π = (P.e μ.val).coeff ((permCast μ.prop).symm π) := by - show symCast (le_of_eq μ.prop) (P.e μ.val) π = - P.e μ.val ((permCast μ.prop).symm π) + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreExact.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreExact.lean index 6eb7b53404..8318436c4e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreExact.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreExact.lean @@ -284,7 +284,7 @@ theorem gammaModuleFunctor_map_add refine LinearMap.ext fun m => ?_ <;> · show m ≫ Mod.Hom.hom f + m ≫ Mod.Hom.hom g = m ≫ Mod.Hom.hom h - rw [← Preadditive.comp_add, hfg] + erw [← Preadditive.comp_add, hfg] section Splitting diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFaithful.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFaithful.lean index 393995fd72..69b54f4b66 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFaithful.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFaithful.lean @@ -79,9 +79,9 @@ private theorem mixTotal ((freeModMap R (biproduct.ι (fun k : Fin p ⊕ Fin q => Sum.elim (fun _ => 𝟙_ D) (fun _ => L.obj) k) i)).hom ≫ e.inv.hom) = _ - simp only [Category.assoc] + repeat' erw [Category.assoc] refine Eq.trans (Finset.sum_congr rfl fun i _ => h i) ?_ - rw [← Preadditive.comp_sum, ← Preadditive.sum_comp] + 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)) _)) ?_ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMu.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMu.lean index 9454b707c4..d6f6201cd8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMu.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMu.lean @@ -65,7 +65,7 @@ noncomputable def fibreMu gammaPairEven L R (freeMod R V) (freeMod R W) (tmulEE _ _ m n) ≫ (freeModTensorIso R V W).hom.hom := rfl - rw [h, gammaPairEven_tmulEE, gpairLin_apply] + erw [h, gammaPairEven_tmulEE, gpairLin_apply] exact Eq.trans (Category.assoc _ _ _) (whisker_eq _ (freeModTensorIso_gpair R V W m n)) @@ -88,7 +88,7 @@ noncomputable def fibreMu gammaPairEven L R (freeMod R V) (freeMod R W) (tmulOO _ _ m n) ≫ (freeModTensorIso R V W).hom.hom := rfl - rw [h, gammaPairEven_tmulOO, gpairLin_apply] + erw [h, gammaPairEven_tmulOO, gpairLin_apply] exact Eq.trans (Category.assoc _ _ _) (whisker_eq _ (freeModTensorIso_gpair R V W m n)) @@ -111,7 +111,7 @@ noncomputable def fibreMu gammaPairOdd L R (freeMod R V) (freeMod R W) (tmulEO _ _ m n) ≫ (freeModTensorIso R V W).hom.hom := rfl - rw [h, gammaPairOdd_tmulEO, gpairLin_apply] + erw [h, gammaPairOdd_tmulEO, gpairLin_apply] exact Eq.trans (Category.assoc _ _ _) (whisker_eq _ (freeModTensorIso_gpair R V W m n)) @@ -134,7 +134,7 @@ noncomputable def fibreMu gammaPairOdd L R (freeMod R V) (freeMod R W) (tmulOE _ _ m n) ≫ (freeModTensorIso R V W).hom.hom := rfl - rw [h, gammaPairOdd_tmulOE, gpairLin_apply] + erw [h, gammaPairOdd_tmulOE, gpairLin_apply] exact Eq.trans (Category.assoc _ _ _) (whisker_eq _ (freeModTensorIso_gpair R V W m n)) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowDesc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowDesc.lean index 73f1d73bd2..f6f5b36a3a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowDesc.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowDesc.lean @@ -332,12 +332,12 @@ private theorem freeLeg_window (A ◁ (tensorPowConcat V (a + 2) b).hom)) := (Category.assoc _ _ _).trans (whisker_eq _ (freeCollapse_concat_collect A V (a + 2) b)) - rw [hglue, MonoidalCategory.tensorHom_def] + erw [hglue, MonoidalCategory.tensorHom_def] simp only [Category.assoc] - rw [← MonoidalCategory.comp_whiskerRight_assoc, + erw [← MonoidalCategory.comp_whiskerRight_assoc, ← MonoidalCategory.comp_whiskerRight_assoc] - simp only [Category.assoc] - rw [hA] + erw [Category.assoc] + erw [hA] rfl /-- **The collapse coequalises the slot relations**: a scalar @@ -353,7 +353,8 @@ theorem freeCollapse_leg subst hab simp only [powCast_rfl, Category.id_comp, modPowLegM, modPowLegN, Category.assoc] - show ((tensorPow D (A ⊗ V) a ◁ winLegM A (freeMod A V).X) ▷ + 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) ▷ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSummand.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSummand.lean index 125a15e895..a9ef72158e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSummand.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSummand.lean @@ -738,6 +738,20 @@ theorem OddLine.mixEntry_comp simp only [mixEntry, Limits.zero_comp, 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. -/ @@ -801,7 +815,7 @@ theorem OddLine.exists_mixMat L.hom_line_scalar hsc (biproduct.components e (Sum.inr j) (Sum.inr j')) refine ⟨A, B, hom_ext_components _ _ fun j k => ?_⟩ - rw [components_mixMat] + erw [components_mixMat] rcases j with i | jj · rcases k with i2 | j2 · exact hA i i2 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetract.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetract.lean index bbd0b3f0b3..b0f276e7be 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetract.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetract.lean @@ -48,7 +48,7 @@ theorem sum_modTensorMapMod 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 - rw [Preadditive.comp_sum] + erw [Preadditive.comp_sum] refine Finset.sum_congr rfl fun i _ => ?_ refine Eq.trans (modTensorπ_map R (g i) (𝟙 N)) (eq_whisker ?_ _) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean index 639fbe3795..8dbd3ff3b3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean @@ -292,7 +292,6 @@ theorem schurKilled_indOf {C : Type v} [SmallCategory C] [MonoidalCategory C] (indOf_map_eq_zero_iff (permAlg X μ.card (P.e μ))).mpr (hdown.mp h0), Limits.zero_comp, Limits.comp_zero] - rfl end AlgebraTransport diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAssoc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAssoc.lean index 00c8bf2541..92f723efc2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAssoc.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAssoc.lean @@ -136,7 +136,7 @@ theorem modTensorAssocCover_cond (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 => rw [associator_naturality_left_assoc, + conv_lhs => erw [associator_naturality_left_assoc, ← whisker_exchange_assoc, modTensor_condition_right, associator_naturality_right_assoc, ← MonoidalCategory.whiskerLeft_comp_assoc, @@ -144,7 +144,8 @@ theorem modTensorAssocCover_cond conv_rhs => rw [MonoidalCategory.comp_whiskerRight, Category.assoc, associator_naturality_middle_assoc] simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] - rw [pentagon_hom_hom_inv_hom_hom_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. -/ @@ -205,14 +206,15 @@ theorem modTensorAssocMid_cond conv_lhs => rw [← MonoidalCategory.comp_whiskerRight_assoc, modTensorπ_actRight] simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] - conv_lhs => rw [whiskerRight_modTensorπ_assocMid, + 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, Category.assoc] - rw [pentagon_assoc] + 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. -/ @@ -268,13 +270,13 @@ theorem modTensorAssocInvCover_cond (M.X ◁ modTensorLegN A N P) ≫ modTensorAssocInvCover A M N P := by rw [modTensorLegM, modTensorLegN, modTensorAssocInvCover] - conv_lhs => rw [associator_inv_naturality_middle_assoc, + conv_lhs => erw [associator_inv_naturality_middle_assoc, ← MonoidalCategory.comp_whiskerRight_assoc, whiskerLeft_actRight_modTensorπ, MonoidalCategory.comp_whiskerRight, MonoidalCategory.comp_whiskerRight] - simp only [Category.assoc] - conv_lhs => rw [modTensor_condition_left, + 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] @@ -332,7 +334,7 @@ theorem modTensorAssocInvMid_cond ((α_ M.X A (modTensor A N P)).hom ≫ (M.X ◁ modTensorAct A N P)) ≫ modTensorAssocInvMid A M N P - conv_lhs => rw [whisker_exchange_assoc, + conv_lhs => erw [whisker_exchange_assoc, whiskerLeft_modTensorπ_assocInvMid, modTensorAssocInvCover, associator_inv_naturality_left_assoc, ← MonoidalCategory.comp_whiskerRight_assoc, hMN] @@ -344,7 +346,8 @@ theorem modTensorAssocInvMid_cond conv_rhs => rw [whiskerLeft_modTensorπ_assocInvMid, modTensorAssocInvCover, associator_inv_naturality_middle_assoc] - rw [← pentagon_hom_inv_inv_inv_hom_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 @@ -390,10 +393,11 @@ theorem modTensorAssocHom_assocInv modTensorAssocInv A M N P = (modTensorπ A M N ▷ P.X) ≫ modTensorπ A (modTensorMod A M N) P - rw [whiskerRight_modTensorπ_assocMid_assoc, modTensorAssocCover] + erw [whiskerRight_modTensorπ_assocMid_assoc, modTensorAssocCover] simp only [Category.assoc] + conv_lhs => erw [Category.assoc] erw [modTensorπ_assocInv] - rw [whiskerLeft_modTensorπ_assocInvMid, + erw [whiskerLeft_modTensorπ_assocInvMid, modTensorAssocInvCover, Iso.hom_inv_id_assoc] /-- The inverse associator retracts the associator. -/ @@ -414,11 +418,12 @@ theorem modTensorAssocInv_assocHom modTensorAssocHom A M N P = (M.X ◁ modTensorπ A N P) ≫ modTensorπ A M (modTensorMod A N P) - rw [whiskerLeft_modTensorπ_assocInvMid_assoc, + erw [whiskerLeft_modTensorπ_assocInvMid_assoc, modTensorAssocInvCover] simp only [Category.assoc] + conv_lhs => erw [Category.assoc] erw [modTensorπ_assocHom] - rw [whiskerRight_modTensorπ_assocMid, + erw [whiskerRight_modTensorπ_assocMid, modTensorAssocCover, Iso.inv_hom_id_assoc] /-- **The associator isomorphism of the tensor product of @@ -476,8 +481,9 @@ theorem modTensorAssocHom_act (α_ A M.X (modTensor A N P)).inv ≫ ((actLeft A M.X ▷ modTensor A N P) ≫ modTensorπ A M (modTensorMod A N P)) := by - rw [modTensorAssocCover] + 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 _ _ _)) @@ -489,7 +495,7 @@ theorem modTensorAssocHom_act ← MonoidalCategory.comp_whiskerRight_assoc, whiskerLeft_modTensorπ_act] simp only [MonoidalCategory.comp_whiskerRight, Category.assoc] - conv_lhs => rw [whiskerRight_modTensorπ_assocMid, + conv_lhs => erw [whiskerRight_modTensorπ_assocMid, modTensorAssocCover, associator_naturality_left_assoc, ← whisker_exchange_assoc] conv_rhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtractDual.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtractDual.lean index d79bf17a6a..29a6648362 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtractDual.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtractDual.lean @@ -514,7 +514,7 @@ noncomputable def splitDecompDual inv := biprod.desc (splitCoevalDual A B φ v d hv) (kernel.ι (splitIdemDual A B φ v w d hv hw)) hom_inv_id := by - rw [biprod.lift_desc, + 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 = @@ -522,7 +522,7 @@ noncomputable def splitDecompDual rw [add_sub_cancel] inv_hom_id := by apply biprod.hom_ext' - · rw [biprod.inl_desc_assoc, Category.comp_id] + · 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δ] @@ -545,25 +545,25 @@ noncomputable def splitDecompDual rw [splitCoevalDual_splitEval A B φ v w d hv hw p hp hδ, Category.id_comp, sub_self] - · rw [biprod.inr_desc_assoc, Category.comp_id] + · erw [biprod.inr_desc_assoc, Category.comp_id] apply biprod.hom_ext - · rw [Category.assoc, biprod.lift_fst, biprod.inr_fst] + · erw [Category.assoc, biprod.lift_fst, biprod.inr_fst] haveI : 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 ?_ - rw [Limits.zero_comp, Category.assoc] + erw [Limits.zero_comp, Category.assoc] exact kernel.condition _ - · rw [Category.assoc, biprod.lift_snd, biprod.inr_snd] + · 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δ)) ?_ - rw [Preadditive.comp_sub, Category.comp_id] + 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 _ From 316c745f0be18f96121d275485398ee7c5127252 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 21 Sep 2026 23:51:21 +0000 Subject: [PATCH 12/46] Port tensor power triangles and induction character splitting --- .../RS/Assembly/BlueprintSchur.lean | 20 +++++++++---------- .../Classical/Deligne/BaseChangeTensor.lean | 4 ++-- .../RS/Classical/Deligne/ChainStage2.lean | 5 +++-- .../RS/Classical/Deligne/FibreMuNat.lean | 8 ++++---- .../RS/Classical/Deligne/FreeNormalise.lean | 4 ++-- .../Deligne/GammaPairRetractRight.lean | 2 +- .../RS/Classical/Deligne/IndSplit.lean | 3 ++- .../RS/Classical/Deligne/ModMultiTriple.lean | 6 ++++-- .../RS/Classical/Deligne/OddSquareIso.lean | 17 +++++++--------- .../RS/Classical/Deligne/PermRepChar.lean | 4 ++-- .../RS/Classical/Deligne/PowMerge.lean | 17 +++++++++++----- .../RS/Classical/Deligne/PowTriangle.lean | 19 +++++++++--------- 12 files changed, 59 insertions(+), 50 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean index 2ed22183be..c81c7d75cc 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean @@ -82,14 +82,14 @@ 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) : ∃ α β, @@ -274,23 +274,23 @@ 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] -/ @@ -301,7 +301,7 @@ 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] @@ -319,7 +319,7 @@ info: @RS.traceZeta_rational_of_object : ∀ {A : Type u_2} [inst : CategoryTheo 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] @@ -342,7 +342,7 @@ info: @RS.traceZeta_superSpectrum_of_object : ∀ {A : Type u_2} [inst : Categor (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] → diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTensor.lean index 1527027ed2..a4a8f7622b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTensor.lean @@ -331,7 +331,7 @@ theorem whiskerLeft_unitSlot_baseChangeAct ← MonoidalCategory.comp_whiskerRight, MonObj.mul_one] monoidal - rw [unitSlot, MonoidalCategory.whiskerLeft_comp, + erw [unitSlot, MonoidalCategory.whiskerLeft_comp, MonoidalCategory.whiskerLeft_comp, Category.assoc, Category.assoc] refine Eq.trans (whisker_eq _ (whisker_eq _ @@ -498,7 +498,7 @@ theorem whiskerLeft_unitSlot_collapseMid rw [associator_inv_naturality_middle_assoc, ← MonoidalCategory.comp_whiskerRight, actRight_one] monoidal - rw [unitSlot, MonoidalCategory.whiskerLeft_comp, + erw [unitSlot, MonoidalCategory.whiskerLeft_comp, MonoidalCategory.whiskerLeft_comp, Category.assoc, Category.assoc] refine Eq.trans (whisker_eq _ (whisker_eq _ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainStage2.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainStage2.lean index f74552e6e8..1b6d040bc3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainStage2.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainStage2.lean @@ -184,7 +184,8 @@ theorem tensorHom_π_chainMul2 (symPowMod A M.X (q + 1 + s)) := modTensorπ_map A (symMulMod A M'.X p r) (symMulMod A M.X q s) - show tensorμ (symPow A M'.X (p + 1)) (symPow A M.X (q + 1)) + 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)) ≫ @@ -195,7 +196,7 @@ theorem tensorHom_π_chainMul2 (symMulMod A M.X q s) = _ refine congrArg (CategoryStruct.comp _) ?_ refine (congrArg (CategoryStruct.comp _) h6).trans ?_ - rw [show (symMulMod A M'.X p r).hom = symMulDesc A M'.X p r + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMuNat.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMuNat.lean index 9a20b5bc52..4fbb08a9b4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMuNat.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMuNat.lean @@ -81,7 +81,7 @@ theorem fibreMu_naturality (tmulEE _ _ (m ≫ R ◁ f) (n ≫ R ◁ g)) := by rw [comp_evenMap_apply, tensorHom_evenMap_tmulEE] rfl - rw [hl, fibreMu_evenMap_tmulEE, comp_evenMap_apply, + erw [hl, fibreMu_evenMap_tmulEE, comp_evenMap_apply, fibreMu_evenMap_tmulEE] exact Eq.trans (whisker_eq _ (hint m n)) (Category.assoc _ _ _).symm @@ -93,7 +93,7 @@ theorem fibreMu_naturality (tmulOO _ _ (m ≫ R ◁ f) (n ≫ R ◁ g)) := by rw [comp_evenMap_apply, tensorHom_evenMap_tmulOO] rfl - rw [hl, fibreMu_evenMap_tmulOO, comp_evenMap_apply, + erw [hl, fibreMu_evenMap_tmulOO, comp_evenMap_apply, fibreMu_evenMap_tmulOO] exact Eq.trans (whisker_eq _ (hint m n)) (Category.assoc _ _ _).symm @@ -105,7 +105,7 @@ theorem fibreMu_naturality (tmulEO _ _ (m ≫ R ◁ f) (n ≫ R ◁ g)) := by rw [comp_oddMap_apply, tensorHom_oddMap_tmulEO] rfl - rw [hl, fibreMu_oddMap_tmulEO, comp_oddMap_apply, + erw [hl, fibreMu_oddMap_tmulEO, comp_oddMap_apply, fibreMu_oddMap_tmulEO] exact Eq.trans (whisker_eq _ (hint m n)) (Category.assoc _ _ _).symm @@ -117,7 +117,7 @@ theorem fibreMu_naturality (tmulOE _ _ (m ≫ R ◁ f) (n ≫ R ◁ g)) := by rw [comp_oddMap_apply, tensorHom_oddMap_tmulOE] rfl - rw [hl, fibreMu_oddMap_tmulOE, comp_oddMap_apply, + erw [hl, fibreMu_oddMap_tmulOE, comp_oddMap_apply, fibreMu_oddMap_tmulOE] exact Eq.trans (whisker_eq _ (hint m n)) (Category.assoc _ _ _).symm diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormalise.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormalise.lean index f6ab01d44a..a62c0c4c26 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormalise.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormalise.lean @@ -45,7 +45,7 @@ theorem freeNormalise modPowπ A (freeMod A V).X (n + 1) := by induction n with | zero => - rw [freeCollapse_freeInsert_one, Category.id_comp] + erw [freeCollapse_freeInsert_one, Category.id_comp] | succ k ih => rw [freeCollapse_freeInsert_succ] refine Eq.trans (Category.assoc _ _ _) ?_ @@ -87,7 +87,7 @@ theorem freeCollapseDesc_section 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 - rw [← Category.assoc, modPowπ_freeCollapseDesc, + erw [← Category.assoc, modPowπ_freeCollapseDesc, freeCollapseSection, ← Category.assoc] refine Eq.trans (freeNormalise A V n) ?_ exact (Category.comp_id _).symm diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetractRight.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetractRight.lean index 55cd0a0dc0..95642aa089 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetractRight.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetractRight.lean @@ -101,7 +101,7 @@ theorem sum_modTensorMapMod_right 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 - rw [Preadditive.comp_sum] + erw [Preadditive.comp_sum] refine Finset.sum_congr rfl fun i _ => ?_ refine Eq.trans (modTensorπ_map R (𝟙 M) (g i)) (eq_whisker ?_ _) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplit.lean index f5b9baac9f..73228492ad 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplit.lean @@ -438,7 +438,8 @@ private theorem pairSum_expand {a b : ℕ} (lam : YoungDiagram) rw [mul_assoc, Finset.sum_mul] congr 1 exact Finset.sum_congr rfl fun τ _ => by ring] - rw [← Finset.mul_sum, indMult] + rw [← Finset.mul_sum] + dsimp only [indMult] ring /-! ### The splitting identity -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMultiTriple.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMultiTriple.lean index 922b406090..1547b1f6fa 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMultiTriple.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMultiTriple.lean @@ -239,7 +239,7 @@ lemma tripleWindowFst_cond modTensorAssocInvCover A X Y Z := by rw [modTensorAssocInvCover] simp only [Iso.hom_inv_id_assoc] - rw [← MonoidalCategory.comp_whiskerRight_assoc, + erw [← MonoidalCategory.comp_whiskerRight_assoc, ← MonoidalCategory.comp_whiskerRight_assoc, modTensor_condition] @@ -453,8 +453,9 @@ lemma whiskerRight_modTensorπ_tripleInv modMultiTripleInv A X Y Z = (α_ X.X Y.X Z.X).hom ≫ tripleResolveInv A X Y Z ≫ modMultiπ A [X, Y, Z] := by + repeat' erw [Category.assoc] erw [modTensorπ_tripleInv] - rw [whiskerRight_modTensorπ_tripleInvMid, tripleInvCover] + erw [whiskerRight_modTensorπ_tripleInvMid, tripleInvCover] /-- The forward comparison retracts the backward comparison. -/ @[reassoc (attr := simp)] @@ -471,6 +472,7 @@ lemma modMultiTripleHom_tripleInv 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquareIso.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquareIso.lean index fe4a27cf71..1b3aa0b393 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquareIso.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquareIso.lean @@ -214,7 +214,7 @@ private theorem oddSqShift_ee (shift (gammaAlgebra D L R).unitMod) (rhoEvenOdd L R (L.sq.inv ≫ (a ▷ L.obj))) (rhoEvenOdd L R (L.sq.inv ≫ (b ▷ L.obj)))) = _ - rw [rhoEvenOdd_expand, rhoEvenOdd_expand, + erw [rhoEvenOdd_expand, rhoEvenOdd_expand, shiftUnitHom_evenMap_tmulEE] rfl @@ -232,7 +232,7 @@ private theorem oddSqShift_oo (shift (gammaAlgebra D L R).unitMod) (rhoOddOdd L R ((λ_ L.obj).inv ≫ (x ▷ L.obj))) (rhoOddOdd L R ((λ_ L.obj).inv ≫ (y ▷ L.obj)))) = _ - rw [rhoOddOdd_expand, rhoOddOdd_expand, + erw [rhoOddOdd_expand, rhoOddOdd_expand, shiftUnitHom_evenMap_tmulOO] rfl @@ -250,7 +250,7 @@ private theorem oddSqShift_eo (shift (gammaAlgebra D L R).unitMod) (rhoEvenOdd L R (L.sq.inv ≫ (a ▷ L.obj))) (rhoOddOdd L R ((λ_ L.obj).inv ≫ (x ▷ L.obj)))) = _ - rw [rhoEvenOdd_expand, rhoOddOdd_expand, + erw [rhoEvenOdd_expand, rhoOddOdd_expand, shiftUnitHom_oddMap_tmulEO] rfl @@ -268,7 +268,7 @@ private theorem oddSqShift_oe (shift (gammaAlgebra D L R).unitMod) (rhoOddOdd L R ((λ_ L.obj).inv ≫ (x ▷ L.obj))) (rhoEvenOdd L R (L.sq.inv ≫ (a ▷ L.obj)))) = _ - rw [rhoOddOdd_expand, rhoEvenOdd_expand, + erw [rhoOddOdd_expand, rhoEvenOdd_expand, shiftUnitHom_oddMap_tmulOE] rfl @@ -340,12 +340,9 @@ theorem isIso_gammaPairComparison_oddSquare [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] : IsIso (gammaPairComparison L R (freeMod R L.obj) (freeMod R L.obj)) := by - haveI hsh : IsIso (oddSqShift L R) := by - haveI : IsIso (SuperCommAlgebra.Mod.tensorHom - (gammaShiftIso L R).hom (gammaShiftIso L R).hom) := - (SuperCommAlgebra.Mod.tensorIso (gammaShiftIso L R) - (gammaShiftIso L R)).isIso_hom - exact IsIso.comp_isIso + haveI hsh : IsIso (oddSqShift L R) := + ((SuperCommAlgebra.Mod.tensorIso (gammaShiftIso L R) (gammaShiftIso L R)).trans + (shiftUnitTensor (shift (gammaAlgebra D L R).unitMod))).isIso_hom haveI hmap : IsIso (oddSqMap L R) := by rw [oddSqMap_eq] refine ⟨-inv (oddSqShift L R), ?_, ?_⟩ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermRepChar.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermRepChar.lean index c9943e86f0..f2c3505575 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermRepChar.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermRepChar.lean @@ -53,8 +53,8 @@ instance colourSpace.mulAction {n p : ℕ} : MulAction (Equiv.Perm (Fin n)) (colourSpace n p) where smul π g := g ∘ ⇑π⁻¹ one_smul g := by - show g ∘ ⇑(1 : Equiv.Perm (Fin n))⁻¹ = g - simp + funext i + rfl mul_smul π ρ g := by show g ∘ ⇑(π * ρ)⁻¹ = (g ∘ ⇑ρ⁻¹) ∘ ⇑π⁻¹ rw [mul_inv_rev] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowMerge.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowMerge.lean index fe04a8b2bc..63ddd958bb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowMerge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowMerge.lean @@ -190,7 +190,10 @@ theorem powPeel_inv_concat [Category.{v} D] [MonoidalCategory D] (X : D) 𝟙 (tensorPow D X (b + 1)) := by rw [hcoh, hsplit] simp only [Category.assoc] - rw [leftUnitor_inv_naturality_assoc, reassoc_of% hcombine'] + 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) @@ -254,7 +257,7 @@ theorem headMod_act [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (show X ⊗ tensorPow D X 0 ⟶ X from (ρ_ X).hom) ≫ (modPowOne A X).inv := by show ((ρ_ X).hom ≫ (λ_ X).inv) ≫ modPowπ A X 1 = _ - rw [Category.assoc] + erw [Category.assoc] rfl have hu : (actLeft A X ▷ tensorPow D X 0) ≫ (show X ⊗ tensorPow D X 0 ⟶ X from (ρ_ X).hom) = @@ -268,8 +271,12 @@ theorem headMod_act [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] have hcoh0 : (α_ A X (𝟙_ D)).inv ≫ (ρ_ (A ⊗ X)).hom = A ◁ (ρ_ X).hom := by monoidal exact hcoh0 - rw [h0, MonoidalCategory.whiskerLeft_comp, Category.assoc, - ← actLeft_modPowOne_inv, reassoc_of% hu, reassoc_of% hcoh] + 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)) ≫ @@ -401,7 +408,7 @@ theorem modPowπ_actRight show (modPowπ A X (a + 1) ▷ A) ≫ ((β_ (modPow A X (a + 1)) A).hom ≫ actLeft A (modPowMod A X a).X) = _ - rw [← Category.assoc, hβ, Category.assoc, hact] + erw [← Category.assoc, hβ, Category.assoc, hact] exact ((reassoc_of% hkey) (modPowπ A X (a + 1))).trans (Category.assoc _ _ _) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowTriangle.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowTriangle.lean index bf4fda3e2b..cf0b0f608e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowTriangle.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowTriangle.lean @@ -57,9 +57,9 @@ theorem modPowOne_pairPow have hinv : ∀ (X : D) [ModObj A X], (modPowOne A X).inv = (λ_ X).inv ≫ modPowπ A X 1 := by intro X _ - rw [modPowOne, Iso.trans_inv] + erw [modPowOne, Iso.trans_inv] rfl - rw [hinv, hinv, ← MonoidalCategory.tensorHom_comp_tensorHom, + erw [hinv, hinv, ← MonoidalCategory.tensorHom_comp_tensorHom, Category.assoc] refine ((congrArg (fun t => ((λ_ M'.X).inv ⊗ₘ (λ_ M.X).inv) ≫ t) @@ -114,7 +114,7 @@ theorem powSeed_pairing 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 - rw [powSeed, Category.assoc] + 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) ≫ @@ -250,17 +250,18 @@ theorem tensorHom_π_interchange_map (modTensorMod A N₂ P₂) ≫ modTensorMap A f g = (f.hom ⊗ₘ g.hom) ≫ modTensorπ A Q R := modTensorπ_map A f g - show tensorμ N₁.X N₂.X P₁.X P₂.X ≫ + conv_lhs => arg 2; 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 f g = _ refine congrArg (CategoryStruct.comp _) ?_ refine (congrArg (CategoryStruct.comp _) h6).trans ?_ - rw [← Category.assoc] + erw [← Category.assoc] show ((modTensorπ A N₁ P₁ ⊗ₘ modTensorπ A N₂ P₂) ≫ (f.hom ⊗ₘ g.hom)) ≫ modTensorπ A Q R = _ - rw [MonoidalCategory.tensorHom_comp_tensorHom] + erw [MonoidalCategory.tensorHom_comp_tensorHom] end InterchangeMap @@ -554,7 +555,7 @@ private theorem powDeltaCore_raw rw [hpeelcast (by omega : 0 + (n + 1) = n + 1), reassoc_of% (concat_peel_head M.X 0 (n + 1)), powPeel_zero, tensorPowConcat_zero_left] - simp only [← MonoidalCategory.whiskerLeft_comp] + 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) = @@ -809,8 +810,7 @@ theorem powDelta_pairing (modPowMod A M'.X (n + 1)) ≫ modPowPairing A M M' d (n + 1)) := by rw [powDelta] - simp only [Category.assoc] - rfl + repeat' erw [Category.assoc] refine hflat.trans ?_ refine ((congrArg (fun t => (ρ_ (powStage A M M' n)).inv ≫ @@ -896,6 +896,7 @@ theorem rawPair_actHead ← 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 ▷ From 05a4adc16118143ea7dde7d2feff8e65947b41e5 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Tue, 22 Sep 2026 00:10:27 +0000 Subject: [PATCH 13/46] Port induction coefficients and relative tensor comparisons --- .../Classical/Deligne/BaseChangeLinear.lean | 2 + .../RS/Classical/Deligne/ChainBridge.lean | 14 ++- .../RS/Classical/Deligne/ChainIns/Base.lean | 8 +- .../RS/Classical/Deligne/GammaPairUnit.lean | 24 ++-- .../RS/Classical/Deligne/IndKill.lean | 109 ++++++------------ .../RS/Classical/Deligne/InterchangeAct.lean | 14 ++- .../RS/Classical/Deligne/PieriPos.lean | 4 +- .../RS/Classical/Deligne/ZigzagSandwich.lean | 4 +- 8 files changed, 77 insertions(+), 102 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeLinear.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeLinear.lean index 477ab7a790..2a4e02df95 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeLinear.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeLinear.lean @@ -504,6 +504,8 @@ theorem assocHom_linear 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBridge.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBridge.lean index 8aeff027d7..96453154dd 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBridge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBridge.lean @@ -289,7 +289,7 @@ theorem projStage_mul (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 - rw [tensorHom_π_interchange_map_assoc, hF, hG, + 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)) @@ -314,7 +314,7 @@ theorem projStage_mul symPowπ A M.X (k + 1 + (0 + 1)))) ≫ modTensorπ A (symPowMod A M'.X (k + 1)) (symPowMod A M.X (k + 1)) := by - rw [BraidedCategory.braiding_naturality_assoc, + erw [BraidedCategory.braiding_naturality_assoc, tensorμ_braiding_right_assoc, MonoidalCategory.tensorHom_comp_tensorHom_assoc] simp only [Category.assoc] @@ -331,7 +331,7 @@ theorem projStage_mul (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 - rw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, + erw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, modTensorπ_projStage A M M' k, modTensorπ_projStage A M M' 0] rfl @@ -373,7 +373,7 @@ theorem projStage_mul modTensorπ A (symPowMod A M'.X 0) (symPowMod A M.X 0)) ≫ chainMul A M M' k 0 := by - rw [← MonoidalCategory.tensorHom_comp_tensorHom_assoc, + 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 ⊗ₘ @@ -422,7 +422,7 @@ theorem projStage_mul symPowπ A M.X (k + 1 + (0 + 1)))) ≫ modTensorπ A (symPowMod A M'.X (k + 1)) (symPowMod A M.X (k + 1)) := by - rw [tensorμ_natural_assoc, + 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)] @@ -456,7 +456,9 @@ theorem powDelta_projStage (ρ_ (powStage A M M' k)).inv) (congrArg (CategoryStruct.comp (powStage A M M' k ◁ powSeed A M M' d)) - (projStage_mul A M M' k)) + (by + erw [Category.assoc] + exact projStage_mul A M M' k)) /-! ## The unit bridge -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/Base.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/Base.lean index e732afef24..8a6719ee02 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/Base.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/Base.lean @@ -350,8 +350,8 @@ theorem chainInsP_cond (symPowMod A M.X q) := modTensor_condition A (symPowMod A M'.X (p + 1)) (symPowMod A M.X q) - rw [reassoc_of% hM, reassoc_of% hN, hcond] - simp only [Category.assoc] + 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 @@ -516,8 +516,8 @@ theorem chainInsQ_cond (symPowMod A M.X (q + 1)) := modTensor_condition A (symPowMod A M'.X p) (symPowMod A M.X (q + 1)) - rw [reassoc_of% hM, reassoc_of% hN, hcond] - simp only [Category.assoc] + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairUnit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairUnit.lean index ca896bf616..c7ac2b2c9e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairUnit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairUnit.lean @@ -51,7 +51,7 @@ theorem gpair_unitLeft (m : Y ⟶ N.X) : gpair (M := regularMod R) (N := N) a m ≫ (modTensorUnitLeftMod R N).hom.hom = gact a m := by - rw [gpair_def, Category.assoc] + erw [gpair_def, Category.assoc] exact whisker_eq _ (modTensorπ_desc R (regularMod R) N _ _) /-- The reindexed form of `RS.gpair_unitLeft`. -/ @@ -88,7 +88,7 @@ theorem gammaPairComparison_unitLeft (tmulEE _ _ a m) = gammaPairEven L R (regularMod R) N (tmulEE _ _ a m) ≫ (modTensorUnitLeftMod R N).hom.hom := rfl - rw [h, gammaPairEven_tmulEE, gpairLin_apply] + 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 @@ -98,7 +98,7 @@ theorem gammaPairComparison_unitLeft (tmulOO _ _ a m) = gammaPairEven L R (regularMod R) N (tmulOO _ _ a m) ≫ (modTensorUnitLeftMod R N).hom.hom := rfl - rw [h, gammaPairEven_tmulOO, gpairLin_apply] + 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 @@ -108,7 +108,7 @@ theorem gammaPairComparison_unitLeft (tmulEO _ _ a m) = gammaPairOdd L R (regularMod R) N (tmulEO _ _ a m) ≫ (modTensorUnitLeftMod R N).hom.hom := rfl - rw [h, gammaPairOdd_tmulEO, gpairLin_apply] + 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 @@ -118,7 +118,7 @@ theorem gammaPairComparison_unitLeft (tmulOE _ _ a m) = gammaPairOdd L R (regularMod R) N (tmulOE _ _ a m) ≫ (modTensorUnitLeftMod R N).hom.hom := rfl - rw [h, gammaPairOdd_tmulOE, gpairLin_apply] + 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 @@ -140,7 +140,7 @@ theorem gpair_unitRight have h : gpair (M := M) (N := regularMod R) m a ≫ (modTensorUnitRightMod R M).hom.hom = (m ⊗ₘ a) ≫ actRight R M.X := by - rw [gpair_def, Category.assoc] + erw [gpair_def, Category.assoc] exact whisker_eq _ (modTensorπ_desc R M (regularMod R) _ _) refine h.trans ?_ rw [actRight, ← Category.assoc, @@ -185,7 +185,7 @@ theorem gammaPairComparison_unitRight (tmulEE _ _ m a) = gammaPairEven L R M (regularMod R) (tmulEE _ _ m a) ≫ (modTensorUnitRightMod R M).hom.hom := rfl - rw [h, gammaPairEven_tmulEE, gpairLin_apply] + 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 @@ -196,7 +196,7 @@ theorem gammaPairComparison_unitRight (tmulOO _ _ m a) = gammaPairEven L R M (regularMod R) (tmulOO _ _ m a) ≫ (modTensorUnitRightMod R M).hom.hom := rfl - rw [h, gammaPairEven_tmulOO, gpairLin_apply] + 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) ?_ @@ -208,7 +208,7 @@ theorem gammaPairComparison_unitRight (tmulEO _ _ m a) = gammaPairOdd L R M (regularMod R) (tmulEO _ _ m a) ≫ (modTensorUnitRightMod R M).hom.hom := rfl - rw [h, gammaPairOdd_tmulEO, gpairLin_apply] + 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 @@ -220,7 +220,7 @@ theorem gammaPairComparison_unitRight (tmulOE _ _ m a) = gammaPairOdd L R M (regularMod R) (tmulOE _ _ m a) ≫ (modTensorUnitRightMod R M).hom.hom := rfl - rw [h, gammaPairOdd_tmulOE, gpairLin_apply] + 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 @@ -275,7 +275,7 @@ instance isIso_gammaPairComparison_unitLeft (N : Mod D R) : IsIso (gammaPairComparison L R (regularMod R) N) := by rw [← gammaPairIsoUnitLeft_hom] - infer_instance + exact (gammaPairIsoUnitLeft L R N).isIso_hom /-- The comparison isomorphism at the regular module on the right. -/ @@ -323,7 +323,7 @@ instance isIso_gammaPairComparison_unitRight (M : Mod D R) : IsIso (gammaPairComparison L R M (regularMod R)) := by rw [← gammaPairIsoUnitRight_hom] - infer_instance + exact (gammaPairIsoUnitRight L R M).isIso_hom end diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean index ce2500df4c..9bf6a57074 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean @@ -5,6 +5,7 @@ Authors: William Whistler -/ import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplit +import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.RegularTrace /-! # The induction kill: block products die with their multiplicity @@ -25,12 +26,10 @@ namespace RS open Finset private theorem ma_add_apply {G : Type*} (f g : MonoidAlgebra ℂ G) - (x : G) : (f + g) x = f x + g x := - Finsupp.add_apply f g x + (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) x = r * f x := - (Finsupp.smul_apply r f x).trans (smul_eq_mul _ _) + (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. -/ @@ -38,33 +37,14 @@ theorem trace_mulLeft_monoidAlgebra {G : Type*} [Group G] [Fintype G] [DecidableEq G] (x : MonoidAlgebra ℂ G) : LinearMap.trace ℂ (MonoidAlgebra ℂ G) (LinearMap.mulLeft ℂ x) = - (Fintype.card G : ℂ) * x 1 := by - classical - have hb : LinearMap.trace ℂ (G →₀ ℂ) - (LinearMap.mulLeft ℂ x) = - Matrix.trace (LinearMap.toMatrix Finsupp.basisSingleOne - Finsupp.basisSingleOne (LinearMap.mulLeft ℂ x)) := - LinearMap.trace_eq_matrix_trace ℂ _ _ - show LinearMap.trace ℂ (G →₀ ℂ) (LinearMap.mulLeft ℂ x) = _ - rw [hb, Matrix.trace] - have hdiag : ∀ g : G, - Matrix.diag (LinearMap.toMatrix Finsupp.basisSingleOne - Finsupp.basisSingleOne (LinearMap.mulLeft ℂ x)) g = - x 1 := by - intro g - rw [Matrix.diag_apply, LinearMap.toMatrix_apply] - simp only [Finsupp.coe_basisSingleOne, - Finsupp.basisSingleOne_repr, LinearEquiv.refl_apply] - exact (MonoidAlgebra.mul_single_apply x 1 g g).trans - (by rw [mul_inv_cancel, mul_one]) - rw [Finset.sum_congr rfl fun g _ => hdiag g, - Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + (Fintype.card G : ℂ) * x.coeff 1 := + 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] [Fintype G] [DecidableEq G] {x : MonoidAlgebra ℂ G} - (hidem : x * x = x) (h1 : x 1 = 0) : x = 0 := by + (hidem : x * x = x) (h1 : x.coeff 1 = 0) : x = 0 := by classical set L := LinearMap.mulLeft ℂ x with hLdef have hLL : L ∘ₗ L = L := by @@ -75,7 +55,7 @@ theorem eq_zero_of_idem_of_coeff_one {G : Type*} [Group G] exact congrArg (fun f => f z) hLL have htr := hproj.trace rw [show LinearMap.trace ℂ (MonoidAlgebra ℂ G) L = - (Fintype.card G : ℂ) * x 1 from + (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 @@ -92,7 +72,7 @@ universe u invariant. -/ theorem shape_e_coeff_conj (P : SchurPackage.{u}) {n : ℕ} (lam : Shape n) (g k : Equiv.Perm (Fin n)) : - Shape.e P lam (g⁻¹ * k * g) = Shape.e P lam k := by + (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) = @@ -120,18 +100,14 @@ theorem shape_e_central (P : SchurPackage.{u}) {n : ℕ} 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 - conv_lhs => rw [← Finsupp.sum_single y] - conv_rhs => rw [← Finsupp.sum_single y] - show Shape.e P lam * (∑ g ∈ y.support, - Finsupp.single g (y g) : SymGroupAlgebra n) = - (∑ g ∈ y.support, - Finsupp.single g (y g) : SymGroupAlgebra n) * Shape.e P lam - rw [Finset.mul_sum, Finset.sum_mul] - exact Finset.sum_congr rfl fun g _ => hsingle g _ + 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.mul_single_apply, - MonoidAlgebra.single_mul_apply] + 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 @@ -240,7 +216,7 @@ theorem blockEmbed_inj {a b : ℕ} {σ σ' : Equiv.Perm (Fin a)} theorem blockAlgEmbed_apply_blockEmbed {a b : ℕ} (x : SymGroupAlgebra a) (y : SymGroupAlgebra b) (σ : Equiv.Perm (Fin a)) (τ : Equiv.Perm (Fin b)) : - blockAlgEmbed x y (blockEmbed σ τ) = x σ * y τ := by + (blockAlgEmbed x y).coeff (blockEmbed σ τ) = x.coeff σ * y.coeff τ := by classical induction x using MonoidAlgebra.induction_on with | of σ₀ => @@ -255,8 +231,8 @@ theorem blockAlgEmbed_apply_blockEmbed {a b : ℕ} intro he exact hcase (blockEmbed_inj he) rcases not_and_or.mp hcase with hσ | hτ - · simp [MonoidAlgebra.single_apply, hne, hσ] - · simp [MonoidAlgebra.single_apply, hne, hτ] + · simp [MonoidAlgebra.coeff_single_apply, hne, hσ] + · simp [MonoidAlgebra.coeff_single_apply, hne, hτ] | add y y' hy hy' => rw [blockAlgEmbed_add_snd, ma_add_apply, hy, hy', ma_add_apply, mul_add] @@ -278,7 +254,7 @@ theorem blockAlgEmbed_apply_eq_zero {a b : ℕ} {g : Equiv.Perm (Fin (a + b))} (h : ∀ (σ : Equiv.Perm (Fin a)) (τ : Equiv.Perm (Fin b)), g ≠ blockEmbed σ τ) : - blockAlgEmbed x y g = 0 := by + (blockAlgEmbed x y).coeff g = 0 := by classical induction x using MonoidAlgebra.induction_on with | of σ₀ => @@ -300,21 +276,10 @@ theorem blockAlgEmbed_apply_eq_zero {a b : ℕ} /-- Convolution at the identity. -/ theorem mul_apply_one {G : Type*} [Group G] [Fintype G] [DecidableEq G] (x y : MonoidAlgebra ℂ G) : - (x * y) 1 = ∑ g : G, x g * y g⁻¹ := by + (x * y).coeff 1 = ∑ g : G, x.coeff g * y.coeff g⁻¹ := by classical - conv_lhs => rw [← Finsupp.sum_single x] - show ((∑ g ∈ x.support, MonoidAlgebra.single g (x g)) * y) 1 = _ - rw [Finset.sum_mul] - have happ : ((∑ g ∈ x.support, - MonoidAlgebra.single g (x g) * y)) 1 = - ∑ g ∈ x.support, - (MonoidAlgebra.single g (x g) * y) 1 := - Finsupp.finsetSum_apply x.support - (fun g => MonoidAlgebra.single g (x g) * y) 1 - rw [happ] - rw [Finset.sum_congr rfl fun g _ => - (MonoidAlgebra.single_mul_apply y (x g) g 1).trans - (by rw [mul_one])] + 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] @@ -323,23 +288,23 @@ 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 ν)) 1 = + 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 g * - blockAlgEmbed (Shape.e P μ) (Shape.e P ν) g⁻¹) = + (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 g⁻¹ * - blockAlgEmbed (Shape.e P μ) (Shape.e P ν) g := + (Shape.e P lam).coeff g⁻¹ * + (blockAlgEmbed (Shape.e P μ) (Shape.e P ν)).coeff g := Fintype.sum_equiv (Equiv.inv _) _ _ fun g => by - show Shape.e P lam g * - blockAlgEmbed (Shape.e P μ) (Shape.e P ν) g⁻¹ = - Shape.e P lam g⁻¹⁻¹ * - blockAlgEmbed (Shape.e P μ) (Shape.e P ν) g⁻¹ + show (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 : @@ -347,8 +312,8 @@ theorem shape_e_mul_block_apply_one (P : SchurPackage.{u}) 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 g⁻¹ * - blockAlgEmbed (Shape.e P μ) (Shape.e P ν) g = 0 := by + (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 ⟨(σ, τ), @@ -363,8 +328,8 @@ theorem shape_e_mul_block_apply_one (P : SchurPackage.{u}) rw [Finset.sum_product] have hterm : ∀ (σ : Equiv.Perm (Fin a)) (τ : Equiv.Perm (Fin b)), - Shape.e P lam (blockEmbed σ τ)⁻¹ * - blockAlgEmbed (Shape.e P μ) (Shape.e P ν) + (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 : ℂ))) * @@ -375,7 +340,7 @@ theorem shape_e_mul_block_apply_one (P : SchurPackage.{u}) jtChar ν.val (permCast ν.prop.symm τ)) := by intro σ τ rw [blockAlgEmbed_apply_blockEmbed] - have h1 : Shape.e P lam ((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 @@ -384,10 +349,10 @@ theorem shape_e_mul_block_apply_one (P : SchurPackage.{u}) exact hc have h2 := shape_e_coeff P μ σ have h3 := shape_e_coeff P ν τ - rw [h1, show (Shape.e P μ) σ = + rw [h1, show (Shape.e P μ).coeff σ = ((P.dim μ.val : ℂ) / ((a.factorial : ℂ))) * jtChar μ.val (permCast μ.prop.symm σ) from h2, - show (Shape.e P ν) τ = + show (Shape.e P ν).coeff τ = ((P.dim ν.val : ℂ) / ((b.factorial : ℂ))) * jtChar ν.val (permCast ν.prop.symm τ) from h3] ring diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean index 932f0a4652..bb7261f2e6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean @@ -90,8 +90,8 @@ theorem interchange_actLeft (modTensorMod A N₂ P₂) := whiskerLeft_modTensorπ_act A (modTensorMod A N₁ P₁) (modTensorMod A N₂ P₂) - rw [MonoidalCategory.whiskerLeft_comp, Category.assoc, hTpin] - simp only [Category.assoc] + erw [MonoidalCategory.whiskerLeft_comp, Category.assoc, hTpin] + repeat' erw [Category.assoc] conv_rhs => rw [associator_naturality_middle_assoc, associator_naturality_right_assoc, ← MonoidalCategory.whiskerLeft_comp_assoc, @@ -117,7 +117,7 @@ theorem interchange_actLeft whiskerLeft_modTensorπ_act, Category.comp_id, tensorHom_comp_tensorHom, tensorHom_comp_tensorHom] simp - rw [reassoc_of% hmerge] + 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 = @@ -157,7 +157,7 @@ theorem interchange_comm (modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A P₁ P₂)).mp ?_ conv_lhs => rw [BraidedCategory.braiding_naturality_assoc, tensorHom_π_interchange, rawInterchangeπ, rawInterchange] - conv_rhs => rw [tensorHom_π_interchange_assoc, + conv_rhs => erw [tensorHom_π_interchange_assoc, rawInterchangeπ, rawInterchange, Category.assoc, Category.assoc] have hswap : modTensorπ A @@ -199,10 +199,16 @@ theorem interchange_comm 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PieriPos.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PieriPos.lean index 75fae416a7..27be0b2d94 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PieriPos.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PieriPos.lean @@ -554,8 +554,8 @@ private theorem sum_stripDiagram_graded {ℓ n : ℕ} (j := fun μ _ => fun i : Fin ℓ => μ.val.rowLen (i : ℕ)) ?_ ?_ ?_ ?_ ?_ · intro r hr - rw [Finset.mem_filter] - exact ⟨Finset.mem_univ _, hp r (Finset.mem_filter.mp hr).1⟩ + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagSandwich.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagSandwich.lean index 79004d02a7..2af7daf7ba 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagSandwich.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagSandwich.lean @@ -59,7 +59,7 @@ theorem modTensorπ_sandwichCon intro Z h rw [← Category.assoc, whiskerRight_modTensorπ_assocMid, modTensorAssocCover] - simp only [Category.assoc] + repeat' erw [Category.assoc] have tail : modTensorπ A M (modTensorMod A M' M) ≫ modTensorMap A (𝟙 M) (d.pairMod) ≫ (modTensorUnitRight A M).hom = @@ -202,7 +202,7 @@ theorem modTensorπ_sandwichConR intro Z h rw [← Category.assoc, whiskerLeft_modTensorπ_assocInvMid, modTensorAssocInvCover] - simp only [Category.assoc] + repeat' erw [Category.assoc] have tail : modTensorπ A (modTensorMod A M' M) M' ≫ modTensorMap A (d.pairMod) (𝟙 M') ≫ (modTensorUnitLeft A M').hom = From 3d3a9a9e1d337316c616c92a4006508d889524b6 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Tue, 22 Sep 2026 00:23:16 +0000 Subject: [PATCH 14/46] Factor fibre monoidal coherence through typed products --- .../RS/Classical/Deligne/FibreMonoidal.lean | 636 +++++++++++++++--- 1 file changed, 560 insertions(+), 76 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMonoidal.lean index 935c98f2c3..917634332d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMonoidal.lean @@ -440,6 +440,529 @@ theorem gammaFunMap_freeModMap_oddMap /-! ## 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 @@ -462,54 +985,15 @@ theorem fibreMu_associativity (𝟙 (gammaModule D L R (freeMod R V).X)) (fibreMu L R W Z) ≫ fibreMu L R V (W ⊗ 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, - 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, fibreMu_evenMap_tmulEE, - fibreMu_evenMap_tmulOO, fibreMu_oddMap_tmulEO, - fibreMu_oddMap_tmulOE, gammaFunMap_freeModMap_evenMap, - gammaFunMap_freeModMap_oddMap] - · refine freeModShuffle_assoc_at' R _ _ _ _ ?_ m n p - monoidal - · 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] - · 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 - · 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] - · refine freeModShuffle_assoc_at' R _ _ _ _ ?_ m n p - monoidal - · 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] - · refine freeModShuffle_assoc_at' R _ _ _ _ ?_ m n p - monoidal - · refine freeModShuffle_assoc_at' R _ _ _ _ ?_ m n p - monoidal + 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 -/ @@ -530,21 +1014,21 @@ theorem fibreMu_left_unitality gammaFunMap L R (freeModMap R (λ_ V).hom) := by refine hom_ext (fun x m => ?_) (fun u m => ?_) (fun x m => ?_) (fun u m => ?_) - · rw [leftUnitorHom_evenMap_tmulEE, comp_evenMap_apply, + · erw [leftUnitorHom_evenMap_tmulEE, comp_evenMap_apply, comp_evenMap_apply, tensorHom_evenMap_tmulEE, - fibreMu_evenMap_tmulEE, gammaFunMap_freeModMap_evenMap] + typedFibreMuEE, typedFibreMapEven] exact (freeModShuffle_unit_left_at' R (λ_ (𝟙_ D)).inv x m).symm - · rw [leftUnitorHom_evenMap_tmulOO, comp_evenMap_apply, + · erw [leftUnitorHom_evenMap_tmulOO, comp_evenMap_apply, comp_evenMap_apply, tensorHom_evenMap_tmulOO, - fibreMu_evenMap_tmulOO, gammaFunMap_freeModMap_evenMap] + typedFibreMuOO, typedFibreMapEven] exact (freeModShuffle_unit_left_at' R L.sq.inv u m).symm - · rw [leftUnitorHom_oddMap_tmulEO, comp_oddMap_apply, + · erw [leftUnitorHom_oddMap_tmulEO, comp_oddMap_apply, comp_oddMap_apply, tensorHom_oddMap_tmulEO, - fibreMu_oddMap_tmulEO, gammaFunMap_freeModMap_oddMap] + typedFibreMuEO, typedFibreMapOdd] exact (freeModShuffle_unit_left_at' R (λ_ L.obj).inv x m).symm - · rw [leftUnitorHom_oddMap_tmulOE, comp_oddMap_apply, + · erw [leftUnitorHom_oddMap_tmulOE, comp_oddMap_apply, comp_oddMap_apply, tensorHom_oddMap_tmulOE, - fibreMu_oddMap_tmulOE, gammaFunMap_freeModMap_oddMap] + typedFibreMuOE, typedFibreMapOdd] exact (freeModShuffle_unit_left_at' R (ρ_ L.obj).inv u m).symm /-- **Right unitality of the monoidal comparison of the fibre @@ -567,21 +1051,21 @@ theorem fibreMu_right_unitality gammaFunMap L R (freeModMap R (ρ_ V).hom) := by refine hom_ext (fun m x => ?_) (fun m u => ?_) (fun m u => ?_) (fun m x => ?_) - · rw [rightUnitorHom_evenMap_tmulEE, comp_evenMap_apply, + · erw [rightUnitorHom_evenMap_tmulEE, comp_evenMap_apply, comp_evenMap_apply, tensorHom_evenMap_tmulEE, - fibreMu_evenMap_tmulEE, gammaFunMap_freeModMap_evenMap] + typedFibreMuEE, typedFibreMapEven] exact (freeModShuffle_unit_right_ee R V m x).symm - · rw [rightUnitorHom_evenMap_tmulOO, comp_evenMap_apply, + · erw [rightUnitorHom_evenMap_tmulOO, comp_evenMap_apply, comp_evenMap_apply, tensorHom_evenMap_tmulOO, - fibreMu_evenMap_tmulOO, gammaFunMap_freeModMap_evenMap] + typedFibreMuOO, typedFibreMapEven] exact (freeModShuffle_unit_right_oo L R V m u).symm - · rw [rightUnitorHom_oddMap_tmulEO, comp_oddMap_apply, + · erw [rightUnitorHom_oddMap_tmulEO, comp_oddMap_apply, comp_oddMap_apply, tensorHom_oddMap_tmulEO, - fibreMu_oddMap_tmulEO, gammaFunMap_freeModMap_oddMap] + typedFibreMuEO, typedFibreMapOdd] exact (freeModShuffle_unit_right_eo L R V m u).symm - · rw [rightUnitorHom_oddMap_tmulOE, comp_oddMap_apply, + · erw [rightUnitorHom_oddMap_tmulOE, comp_oddMap_apply, comp_oddMap_apply, tensorHom_oddMap_tmulOE, - fibreMu_oddMap_tmulOE, gammaFunMap_freeModMap_oddMap] + typedFibreMuOE, typedFibreMapOdd] exact (freeModShuffle_unit_right_oe L R V m x).symm /-! ## Compatibility with the braiding -/ @@ -605,21 +1089,21 @@ theorem fibreMu_braided gammaFunMap L R (freeModMap R (β_ V W).hom) := by refine hom_ext (fun m n => ?_) (fun m n => ?_) (fun m n => ?_) (fun m n => ?_) - · rw [comp_evenMap_apply, braidingHom_evenMap_tmulEE, - fibreMu_evenMap_tmulEE, comp_evenMap_apply, - fibreMu_evenMap_tmulEE, gammaFunMap_freeModMap_evenMap] + · erw [comp_evenMap_apply, braidingHom_evenMap_tmulEE, + typedFibreMuEE, comp_evenMap_apply, + typedFibreMuEE, typedFibreMapEven] exact (freeModShuffle_braiding_ee R V W m n).symm - · rw [comp_evenMap_apply, braidingHom_evenMap_tmulOO, map_neg, - fibreMu_evenMap_tmulOO, comp_evenMap_apply, - fibreMu_evenMap_tmulOO, gammaFunMap_freeModMap_evenMap] + · 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 - · rw [comp_oddMap_apply, braidingHom_oddMap_tmulEO, - fibreMu_oddMap_tmulOE, comp_oddMap_apply, - fibreMu_oddMap_tmulEO, gammaFunMap_freeModMap_oddMap] + · erw [comp_oddMap_apply, braidingHom_oddMap_tmulEO, + typedFibreMuOE, comp_oddMap_apply, + typedFibreMuEO, typedFibreMapOdd] exact (freeModShuffle_braiding_eo L R V W m n).symm - · rw [comp_oddMap_apply, braidingHom_oddMap_tmulOE, - fibreMu_oddMap_tmulEO, comp_oddMap_apply, - fibreMu_oddMap_tmulOE, gammaFunMap_freeModMap_oddMap] + · 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 -/ From 1a53a277303bc48a1baf6b15415684a29b499963 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Tue, 22 Sep 2026 00:38:08 +0000 Subject: [PATCH 15/46] Port remaining tensor and chain coherence frontier to Lean 4.34 --- .../Deligne/BaseChangeCoherence.lean | 12 +-- .../RS/Classical/Deligne/BiprodTransfer.lean | 3 +- .../RS/Classical/Deligne/ChainBofA.lean | 2 +- .../Classical/Deligne/ChainIns/FirstSlot.lean | 37 +++++----- .../RS/Classical/Deligne/ChainNonzero.lean | 2 +- .../RS/Classical/Deligne/FibreStrong.lean | 2 +- .../RS/Classical/Deligne/KronKill.lean | 74 ++++++++----------- .../RS/Classical/Deligne/SuperVectSchur.lean | 3 +- .../RS/Classical/Deligne/TensorZigzag.lean | 49 ++++++------ .../RS/Classical/Deligne/TwistShuffle.lean | 13 ++-- 10 files changed, 99 insertions(+), 98 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean index c0f15bd808..ba8be0ec58 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean @@ -132,7 +132,7 @@ theorem modTensorAssocMid_unitRight intro Z h rw [← Category.assoc, whiskerRight_modTensorπ_assocMid, modTensorAssocCover] - simp only [Category.assoc] + 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 @@ -283,7 +283,7 @@ theorem modTensorAssocMid_unitLeft intro Z h rw [← Category.assoc, whiskerRight_modTensorπ_assocMid, modTensorAssocCover] - simp only [Category.assoc] + repeat' erw [Category.assoc] have tail : modTensorπ A P (modTensorMod A (regularMod A) N) ≫ modTensorMap A (𝟙 P) (modTensorUnitLeftMod A N).hom = @@ -648,7 +648,7 @@ theorem projFormula_assoc_core simp only [Category.assoc] rw [reassoc_of% (baseMul_natural_left B (modTensorπ A M N) P.X)] - rw [← MonoidalCategory.whiskerLeft_comp, hcov, + erw [← MonoidalCategory.whiskerLeft_comp, hcov, MonoidalCategory.whiskerLeft_comp, MonoidalCategory.whiskerLeft_comp] simp only [Category.assoc] @@ -732,7 +732,7 @@ theorem modTensorAssocMid_natural_right intro Z h rw [← Category.assoc, whiskerRight_modTensorπ_assocMid, modTensorAssocCover] - simp only [Category.assoc] + 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') ≫ @@ -756,6 +756,7 @@ theorem modTensorAssocMid_natural_right (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. -/ @@ -794,7 +795,7 @@ theorem modTensorAssocMid_natural_mid intro Z h rw [← Category.assoc, whiskerRight_modTensorπ_assocMid, modTensorAssocCover] - simp only [Category.assoc] + 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) ≫ @@ -821,6 +822,7 @@ theorem modTensorAssocMid_natural_mid (associator_naturality_middle P.X f.hom N.X) _) ?_ simp only [Category.assoc, MonoidalCategory.whiskerLeft_comp] + repeat' erw [Category.assoc] end AssocMidNatural diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodTransfer.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodTransfer.lean index 1afb1bd0b0..299b0b52d1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodTransfer.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodTransfer.lean @@ -159,7 +159,8 @@ theorem SchurKilled.biprod 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 - rw [Shape.e, symCast_le_refl]] at this + 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) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBofA.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBofA.lean index b8a4319e33..c5837d20cc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBofA.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBofA.lean @@ -95,7 +95,7 @@ theorem chainBofA_unit η[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) - rw [chainBofA, reassoc_of% h] + erw [chainBofA, reassoc_of% h] rfl /-- The chain multiplication is left linear over the base, at the diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/FirstSlot.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/FirstSlot.lean index 89f39251f0..24bec89dd3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/FirstSlot.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/FirstSlot.lean @@ -136,7 +136,7 @@ theorem chainInsP_mul (symPowMod A M.X s)) ≫ chainMul2 A M M' p q r s)) ≫ chainInsP A M M' (p + 1 + r) (q + 1 + s) := by - rw [← Category.assoc, ← MonoidalCategory.whiskerLeft_comp] + 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) @@ -200,7 +200,7 @@ theorem chainInsP_mul (symPowMod A M.X (q + 1 + s))) ≫ chainInsP A M M' (p + 1 + r) (q + 1 + s)) := by rw [l3w1, l3w2] - simp only [Category.assoc] + 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))) ≫ @@ -287,7 +287,7 @@ theorem chainInsP_mul 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 - rw [← MonoidalCategory.tensorHom_id, + 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) => @@ -338,11 +338,14 @@ theorem chainInsP_mul (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₀ := - ((reassoc_of% hα1) - ((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₀)).trans - (Category.assoc _ _ _) + 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 ≫ @@ -429,9 +432,9 @@ theorem chainInsP_mul (symPowMod A M.X s)) ≫ chainMul2 A M M' (p + 1) q r s ≫ chainStage2Cast A M M' hp₀ hq₀ := by - rw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, + erw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, Category.id_comp] - simp only [Category.assoc] + 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 ≫ @@ -468,12 +471,12 @@ theorem chainInsP_mul (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) - (((reassoc_of% - (tensorHom_π_chainMul2 A M M' (p + 1) q r s)) - (chainStage2Cast A M M' hp₀ hq₀)).trans - ((Category.assoc _ _ _).trans - (congrArg (CategoryStruct.comp _) - (Category.assoc _ _ _)))) + (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) 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₀ = @@ -605,7 +608,7 @@ theorem chainInsP_mul 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 [MonoidalCategory.tensorHom_comp_tensorHom_assoc, + erw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, MonoidalCategory.tensorHom_comp_tensorHom_assoc] have h₁ : p + 1 + r + 2 = p + 2 + (r + 1) := by omega have hcc : symPowCast A M'.X h₁ ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainNonzero.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainNonzero.lean index c2c1fe086f..f93e4afb65 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainNonzero.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainNonzero.lean @@ -54,7 +54,7 @@ theorem chainUnitStage_eq_symCopair rw [projStage] exact (modTensorMap_swap A (symPowπMod A n) (symPowπMod A n)).symm - rw [h1, Category.assoc, ← powUnitStage_projStage A M M' d n, + erw [h1, Category.assoc, ← powUnitStage_projStage A M M' d n, hproj, reassoc_of% (powCopairA_unit A M M' d n)] rfl diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreStrong.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreStrong.lean index e2f74f0251..c9550c421e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreStrong.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreStrong.lean @@ -63,7 +63,7 @@ noncomputable def fibreOverMonoidal haveI : IsIso (CategoryTheory.Functor.LaxMonoidal.ε (fibreOver L R)) := by rw [fibreOver_ε] - infer_instance + 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_μ] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean index cead62807d..d6de490fe9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean @@ -25,12 +25,10 @@ namespace RS open Finset private theorem ma_add_apply {G : Type*} (f g : MonoidAlgebra ℂ G) - (x : G) : (f + g) x = f x + g x := - Finsupp.add_apply f g x + (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) x = r * f x := - (Finsupp.smul_apply r f x).trans (smul_eq_mul _ _) + (f : MonoidAlgebra ℂ G) (x : G) : (r • f).coeff x = r * f.coeff x := rfl universe u @@ -197,7 +195,7 @@ theorem extProd_smul_snd {n : ℕ} (r : ℂ) the coefficients. -/ theorem extProd_apply_pair {n : ℕ} (x y : SymGroupAlgebra n) (σ τ : Equiv.Perm (Fin n)) : - extProd x y (σ, τ) = x σ * y τ := by + (extProd x y).coeff (σ, τ) = x.coeff σ * y.coeff τ := by classical induction x using MonoidAlgebra.induction_on with | of σ₀ => @@ -213,8 +211,8 @@ theorem extProd_apply_pair {n : ℕ} (x y : SymGroupAlgebra n) intro he exact hcase ⟨congrArg Prod.fst he, congrArg Prod.snd he⟩ rcases not_and_or.mp hcase with hσ | hτ - · simp [MonoidAlgebra.single_apply, hne, hσ] - · simp [MonoidAlgebra.single_apply, hne, hτ] + · simp [MonoidAlgebra.coeff_single_apply, hne, hσ] + · simp [MonoidAlgebra.coeff_single_apply, hne, hτ] | add y y' hy hy' => rw [extProd_add_snd, ma_add_apply, hy, hy', ma_add_apply, mul_add] @@ -233,11 +231,11 @@ 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 ν) (g⁻¹ * k * g) = - extProd (Shape.e P μ) (Shape.e P ν) k := by - show extProd (Shape.e P μ) (Shape.e P ν) + (extProd (Shape.e P μ) (Shape.e P ν)).coeff (g⁻¹ * k * g) = + (extProd (Shape.e P μ) (Shape.e P ν)).coeff k := by + show (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 ν) (k.1, k.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] @@ -256,22 +254,14 @@ theorem extProd_shape_e_central (P : SchurPackage.{u}) {n : ℕ} MonoidAlgebra.single g c = MonoidAlgebra.single g c * extProd (Shape.e P μ) (Shape.e P ν) by - conv_lhs => rw [← Finsupp.sum_single z] - conv_rhs => rw [← Finsupp.sum_single z] - show extProd (Shape.e P μ) (Shape.e P ν) * - (∑ g ∈ z.support, Finsupp.single g (z g) : - MonoidAlgebra ℂ - (Equiv.Perm (Fin n) × Equiv.Perm (Fin n))) = - (∑ g ∈ z.support, Finsupp.single g (z g) : - MonoidAlgebra ℂ - (Equiv.Perm (Fin n) × Equiv.Perm (Fin n))) * - extProd (Shape.e P μ) (Shape.e P ν) - rw [Finset.mul_sum, Finset.sum_mul] - exact Finset.sum_congr rfl fun g _ => hsingle g _ + 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.mul_single_apply, - MonoidAlgebra.single_mul_apply] + 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 @@ -286,16 +276,16 @@ theorem diagHom_injective (n : ℕ) : /-- The diagonal image's coefficient on the diagonal. -/ theorem diagEmbed_apply_diag {n : ℕ} (x : SymGroupAlgebra n) - (σ : Equiv.Perm (Fin n)) : diagEmbed x (σ, σ) = x σ := by - show Finsupp.mapDomain (diagHom n) x (σ, σ) = x σ - exact Finsupp.mapDomain_apply (diagHom_injective n) x σ + (σ : Equiv.Perm (Fin n)) : (diagEmbed x).coeff (σ, σ) = x.coeff σ := by + show 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 p = 0 := by - show Finsupp.mapDomain (diagHom n) x p = 0 - refine Finsupp.mapDomain_notin_range x p ?_ + (h : p.1 ≠ p.2) : (diagEmbed x).coeff p = 0 := by + show 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 @@ -305,22 +295,22 @@ 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)) (1, 1) = + 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 show (extProd (Shape.e P μ) (Shape.e P ν) * - diagEmbed (Shape.e P lam)) 1 = _ + 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 ν) p * - diagEmbed (Shape.e P lam) p⁻¹ = 0 := by + (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 @@ -333,8 +323,8 @@ theorem extProd_mul_diagEmbed_apply_one (P : SchurPackage.{u}) 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 ν) (σ, σ) * - diagEmbed (Shape.e P lam) ((σ, σ)⁻¹) = + (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 : ℂ)) * @@ -342,20 +332,20 @@ theorem extProd_mul_diagEmbed_apply_one (P : SchurPackage.{u}) jtChar μ.val (permCast μ.prop.symm σ) * jtChar ν.val (permCast ν.prop.symm σ)) := by intro σ - have h2 : diagEmbed (Shape.e P lam) ((σ, σ)⁻¹) = - Shape.e P lam σ⁻¹ := + 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 σ⁻¹ = + 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 μ) σ = + show (Shape.e P μ).coeff σ = ((P.dim μ.val : ℂ) / (n.factorial : ℂ)) * jtChar μ.val (permCast μ.prop.symm σ) from shape_e_coeff P μ σ, - show (Shape.e P ν) σ = + show (Shape.e P ν).coeff σ = ((P.dim ν.val : ℂ) / (n.factorial : ℂ)) * jtChar ν.val (permCast ν.prop.symm σ) from shape_e_coeff P ν σ] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean index a599ac2493..ffbd70f23c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean @@ -345,7 +345,6 @@ theorem tot_associator (V W Z : SuperVect) : SuperVect.assocAux V.even V.odd W.even W.odd Z.odd Z.even from rfl] dsimp only - simp only [LinearMap.fst_apply, LinearMap.snd_apply] 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) @@ -815,7 +814,7 @@ theorem sTr_insertTop_full (X : SuperVect) : induction n with | zero => intro h - rw [show insertTop X 0 0 = 𝟙 _ from insertTop_zero X 0, + erw [show insertTop X 0 0 = 𝟙 _ from insertTop_zero X 0, Category.id_comp] show sTr (𝟙 (tensorPow SuperVect X 0) ⊗ₘ h) = _ rw [sTr_tensorHom, sTr_id, parPow, Category.id_comp] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorZigzag.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorZigzag.lean index 76ad7d131a..69200d44bc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorZigzag.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorZigzag.lean @@ -70,7 +70,7 @@ theorem tensorCopair_point interchangeDesc A N₁ N₁' N₂ N₂' = (d₁.copair ⊗ₘ d₂.copair) ≫ interchange A N₁ N₁' N₂ N₂' := by - rw [← Category.assoc, hmap, Category.assoc] + 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₂) @@ -198,7 +198,7 @@ theorem interchange_zigContract regPairFold A := by rw [hpair, ← Category.assoc, modTensorπ_interchangeDesc] rfl - conv_lhs => rw [← whisker_exchange_assoc, + conv_lhs => erw [← whisker_exchange_assoc, ← comp_whiskerRight_assoc, tensorHom_π_interchange, rawInterchangeπ, rawInterchange] have hzdef : (MonoidalCategory.whiskerRight @@ -218,7 +218,10 @@ theorem interchange_zigContract whiskerRight_modTensorπ_zigContract A (tensorDatum A d₁ d₂).pair (tensorDatum A d₁ d₂).pair_linear - conv_lhs => rw [comp_whiskerRight, comp_whiskerRight, + 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 hfold : modTensorπ A (regularMod A) (regularMod A) ≫ @@ -260,18 +263,18 @@ theorem interchange_zigContract (modTensorπ A N₁' N₁ ⊗ₘ modTensorπ A N₂' N₂) ≫ t) t2).trans (by rw [← MonoidalCategory.tensorHom_comp_tensorHom_assoc]) - rw [← Category.assoc, tensorHom_π_interchange, - rawInterchangeπ, rawInterchange, Category.assoc, - Category.assoc] - exact congrArg (fun t : (N₁'.X ⊗ N₁.X) ⊗ (N₂'.X ⊗ N₂.X) ⟶ + 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 conv_lhs => rw [hinner] - conv_lhs => rw [whisker_exchange_assoc + 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 => rw [← reassoc_of% (MonoidalCategory.tensorHom_def + 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₂') ⊗ₘ @@ -518,7 +521,7 @@ theorem interchange_zagContract regPairFold A := by rw [hpair, ← Category.assoc, modTensorπ_interchangeDesc] rfl - conv_lhs => rw [whisker_exchange_assoc + conv_lhs => erw [whisker_exchange_assoc (modTensorπ A N₁' N₂') (modTensorπ A N₁ N₁' ⊗ₘ modTensorπ A N₂ N₂'), ← MonoidalCategory.whiskerLeft_comp_assoc, @@ -539,8 +542,10 @@ theorem interchange_zagContract whiskerLeft_modTensorπ_zagContract A (tensorDatum A d₁ d₂).pair (tensorDatum A d₁ d₂).pair_linear - conv_lhs => rw [MonoidalCategory.whiskerLeft_comp, - MonoidalCategory.whiskerLeft_comp, + 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₂' ⊗ @@ -554,7 +559,7 @@ theorem interchange_zagContract (modTensorπ A N₁ N₂ ⊗ₘ modTensorπ A N₁' N₂')) ≫ t))) hzagdef) ?_ conv_lhs => rw [hinner] - conv_lhs => rw [← whisker_exchange_assoc + 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₂') @@ -599,12 +604,12 @@ theorem interchange_zagContract (modTensorπ A N₁' N₁ ⊗ₘ modTensorπ A N₂' N₂) ≫ t) t2).trans (by rw [← MonoidalCategory.tensorHom_comp_tensorHom_assoc]) - rw [← Category.assoc, tensorHom_π_interchange, - rawInterchangeπ, rawInterchange, Category.assoc, - Category.assoc] - exact congrArg (fun t : (N₁'.X ⊗ N₁.X) ⊗ (N₂'.X ⊗ N₂.X) ⟶ + 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 - conv_lhs => rw [← reassoc_of% (MonoidalCategory.tensorHom_def' + 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₂' ⊗ₘ @@ -843,7 +848,7 @@ theorem tensorDatum_carrier_zig rw [leftUnitor_inv_naturality_assoc, whisker_exchange] have hcop : (tensorDatum A d₁ d₂).copair = tensorCopair A d₁ d₂ := rfl - rw [← Category.assoc, ← Category.assoc, Category.assoc + 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) ▷ @@ -864,7 +869,7 @@ theorem tensorDatum_carrier_zig rw [comp_whiskerRight] rw [comp_whiskerRight] rw [Category.assoc, Category.assoc] - rw [← whisker_exchange_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 ≫ @@ -926,7 +931,7 @@ theorem tensorDatum_carrier_zag rw [rightUnitor_inv_naturality_assoc, ← whisker_exchange] have hcop : (tensorDatum A d₁ d₂).copair = tensorCopair A d₁ d₂ := rfl - rw [← Category.assoc, ← Category.assoc, Category.assoc + 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) ◁ @@ -948,7 +953,7 @@ theorem tensorDatum_carrier_zag rw [MonoidalCategory.whiskerLeft_comp] rw [MonoidalCategory.whiskerLeft_comp] rw [Category.assoc, Category.assoc] - rw [whisker_exchange_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 ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistShuffle.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistShuffle.lean index bac8fbc961..0569898b2d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistShuffle.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistShuffle.lean @@ -218,7 +218,7 @@ theorem twistShuffleInvCover_cond from rfl] simp only [MonoidalCategory.comp_whiskerRight, MonoidalCategory.whiskerLeft_comp, Category.assoc] - rw [reassoc_of% (tensorδ_slide_fst A V W R S), + 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) @@ -253,9 +253,10 @@ theorem twistShuffleInvCover_cond (W ◁ actLeft A S.X)))) ≫ modTensorπ A (tensorLeftMod A V R) (tensorLeftMod A W S) := hcond - simpa only [MonoidalCategory.comp_whiskerRight, - MonoidalCategory.whiskerLeft_comp, Category.assoc] - using h' + 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) = @@ -341,7 +342,7 @@ theorem twistShuffleHom_twistShuffleInv ((V ⊗ W) ◁ modTensorπ A R S)) ≫ twistShuffleInv A V W R S = modTensorπ A (tensorLeftMod A V R) (tensorLeftMod A W S) - rw [Category.assoc, whiskerLeft_π_twistShuffleInv, + erw [Category.assoc, whiskerLeft_π_twistShuffleInv, twistShuffleInvCover, ← Category.assoc, tensorμ_tensorδ, Category.id_comp] @@ -362,7 +363,7 @@ theorem twistShuffleInv_twistShuffleHom (tensorLeftMod A W S)) ≫ twistShuffleHom A V W R S = (V ⊗ W) ◁ modTensorπ A R S - rw [Category.assoc] + erw [Category.assoc] erw [modTensorπ_twistShuffleHom] rw [twistShuffleCover, ← Category.assoc, tensorδ_tensorμ, Category.id_comp] From e1c613c5c54f3c9df7ee30796c3d20ac4ada8cff Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Tue, 22 Sep 2026 00:55:05 +0000 Subject: [PATCH 16/46] Port scalar braiding and monoidal base-change coherence --- .../Classical/Deligne/BaseChangeMonoidal.lean | 42 ++++++++++++++++--- .../Deligne/ChainIns/SecondSlot.lean | 41 +++++++++--------- .../RS/Classical/Deligne/CoverFactor.lean | 5 ++- .../RS/Classical/Deligne/FibreRestrict.lean | 3 +- .../RS/Classical/Deligne/FreeTwistPi.lean | 2 +- .../RS/Classical/Deligne/PowSucc.lean | 3 +- .../RS/Classical/Deligne/ScalarBraiding.lean | 31 +++++++------- .../RS/Classical/Deligne/TensorTransfer.lean | 11 +++-- 8 files changed, 87 insertions(+), 51 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeMonoidal.lean index 551e39631a..b96cbed3c8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeMonoidal.lean @@ -140,6 +140,7 @@ theorem projFormula_natural_right refine Eq.trans (Category.assoc _ _ _).symm ?_ refine Eq.trans (eq_whisker (hend _ _) _) ?_ simp only [Category.assoc] + conv_lhs => erw [Category.assoc]; arg 2; erw [Category.assoc] rfl /-- **The structure map is natural in the first slot.** -/ @@ -315,6 +316,7 @@ theorem projFormula_assoc_leftCover (projFormula A B φ M N).hom (modTensorπ A (restrictRegular φ) P)) _) ?_ simp only [Category.assoc] + erw [Category.assoc] rfl have hcore2 : ∀ {Z : D} (h : (baseChangeMod φ (modTensorMod A M N)).X ⊗ @@ -342,6 +344,8 @@ theorem projFormula_assoc_leftCover 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 @@ -371,9 +375,18 @@ theorem projFormula_assoc_leftCover (B ◁ modTensorAssocMid A M N P) ≫ modTensorπ A (restrictRegular φ) (modTensorMod A M (modTensorMod A N P)) := by - refine Eq.trans ((reassoc_of% - (projFormula_tensorμ_cover A B φ - (modTensorMod A M N) P)) _) ?_ + 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 _ @@ -505,6 +518,7 @@ theorem projFormula_assoc_rightCover 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))) ≫ @@ -521,7 +535,7 @@ theorem projFormula_assoc_rightCover ((baseChangeMod φ M).X ◁ modTensorπ A (restrictRegular φ) (modTensorMod A N P)) := by - simp only [← MonoidalCategory.whiskerLeft_comp] + repeat' erw [← MonoidalCategory.whiskerLeft_comp] exact congrArg (fun t => (baseChangeMod φ M).X ◁ t) hfoldNP have hfoldM : (modTensorπ A (restrictRegular φ) M ▷ @@ -607,7 +621,25 @@ theorem projFormula_assoc have hc := eq_whisker (projFormula_assoc_core A B M N P) (modTensorπ A (restrictRegular φ) (modTensorMod A M (modTensorMod A N P))) - simpa only [Category.assoc] using hc + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/SecondSlot.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/SecondSlot.lean index 7226aab07a..4d6dc02f74 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/SecondSlot.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/SecondSlot.lean @@ -220,7 +220,7 @@ theorem chainInsQ_mul (symPowMod A M.X s)) ≫ chainMul2 A M M' p q r s)) ≫ chainInsQ A M M' (p + 1 + r) (q + 1 + s) := by - rw [← Category.assoc, ← MonoidalCategory.whiskerLeft_comp] + 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) @@ -284,7 +284,7 @@ theorem chainInsQ_mul (symPowMod A M.X (q + 1 + s))) ≫ chainInsQ A M M' (p + 1 + r) (q + 1 + s)) := by rw [l3w1, l3w2] - simp only [Category.assoc] + 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))) ≫ @@ -458,11 +458,14 @@ theorem chainInsQ_mul (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₀ := - ((reassoc_of% hα1) - ((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₀)).trans - (Category.assoc _ _ _) + 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 ≫ @@ -561,9 +564,9 @@ theorem chainInsQ_mul (symPowMod A M.X s)) ≫ chainMul2 A M M' p (q + 1) r s ≫ chainStage2Cast A M M' hp₀ hq₀ := by - rw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, + erw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, Category.id_comp] - simp only [Category.assoc] + 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 ≫ @@ -612,12 +615,12 @@ theorem chainInsQ_mul (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) - (((reassoc_of% - (tensorHom_π_chainMul2 A M M' p (q + 1) r s)) - (chainStage2Cast A M M' hp₀ hq₀)).trans - ((Category.assoc _ _ _).trans - (congrArg (CategoryStruct.comp _) - (Category.assoc _ _ _)))) + (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₀ = @@ -790,7 +793,7 @@ theorem chainInsQ_mul 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 [MonoidalCategory.tensorHom_comp_tensorHom_assoc, + erw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, MonoidalCategory.tensorHom_comp_tensorHom_assoc] have h₁ : q + 1 + s + 2 = q + 2 + (s + 1) := by omega have hcc : symPowCast A M.X h₁ ≫ @@ -821,8 +824,8 @@ theorem chainInsQ_mul 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) - simp only [Category.assoc] - rw [reassoc_of% (symInsL_symMul A M.X q 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))) @@ -948,7 +951,7 @@ theorem chainInsQ_delta2 ((M.X ◁ chainMul2 A M M' p q 0 0) ≫ chainInsQ A M M' (p + 1) (q + 1)) := by rw [w1, w2] - simp only [Category.assoc] + 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoverFactor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoverFactor.lean index 37c9474cae..8c3036fd67 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoverFactor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoverFactor.lean @@ -33,7 +33,7 @@ theorem modPowπ_one [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [MonObj A] (X : D) [ModObj A X] : modPowπ A X 1 ≫ (modPowOne A X).hom = (λ_ X).hom := by - rw [modPowOne, Iso.trans_hom, ← Category.assoc, + 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, @@ -131,7 +131,7 @@ private theorem twistPow_cover_factor_zero ((𝟙_ D ⊗ V) ◁ (modPowOne A R.X).inv))) = (plainShuffle V R.X 1).hom ≫ ((𝟙_ D ⊗ V) ◁ modPowπ A R.X 1) - rw [← Category.assoc, modPowπ_one, modPowOne_inv, + 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) = @@ -386,6 +386,7 @@ theorem twistPow_cover_factor (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 ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreRestrict.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreRestrict.lean index 5820f86589..499294aa43 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreRestrict.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreRestrict.lean @@ -56,7 +56,8 @@ noncomputable def fibreRestrictMonoidal rw [CategoryTheory.Functor.LaxMonoidal.comp_ε] have h1 : IsIso (CategoryTheory.Functor.LaxMonoidal.ε (fibreOver L R)) := by - rw [fibreOver_ε]; infer_instance + rw [fibreOver_ε] + exact (fibreEpsIso L R).isIso_hom exact IsIso.comp_isIso' h1 (@CategoryTheory.Functor.map_isIso _ _ _ _ _ _ (fibreOver L R) (CategoryTheory.Functor.LaxMonoidal.ε F) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeTwistPi.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeTwistPi.lean index a3f76387a0..6ee7bed123 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeTwistPi.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeTwistPi.lean @@ -97,7 +97,7 @@ theorem freeTensorTwistIso_gpair (freeTensorTwistIso A V M).hom.hom = (m ⊗ₘ n) ≫ ((β_ A V).hom ▷ M.X) ≫ (α_ V A M.X).hom ≫ (V ◁ actLeft A M.X) := by - rw [gpair_def, Category.assoc] + erw [gpair_def, Category.assoc] exact whisker_eq _ (modTensorπ_freeTensorTwistIso A V M) end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSucc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSucc.lean index faf6d22ca7..4f1353070d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSucc.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSucc.lean @@ -206,10 +206,11 @@ theorem powCopairA_succ_tensor modPowCastMod A M.X (by omega : 0 + 1 + n + 1 = n + 2)) (powMulMod A M'.X n 0)) h2) ?_ - rw [reassoc_of% hpt] + erw [reassoc_of% hpt] show _ = 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarBraiding.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarBraiding.lean index c2915d87b4..be1023bb94 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarBraiding.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarBraiding.lean @@ -121,17 +121,17 @@ theorem permAlg_of_scalar (hβ : (β_ X X).hom = c • 𝟙 (X ⊗ X)) (hc2 : c * c = 1) {n : ℕ} (x : SymGroupAlgebra n) : permAlg X n x = - (∑ σ : Equiv.Perm (Fin 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.sum fun σ r => r • permMor X n σ := by + x.coeff.sum fun σ r => r • permMor X n σ := by rw [permAlg] exact MonoidAlgebra.lift_apply _ _ rw [hlift] - rw [show (x.sum fun σ r => r • permMor X n σ) = - ∑ σ ∈ x.support, x σ • permMor X n σ from rfl] + 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] @@ -143,12 +143,13 @@ theorem permAlg_of_scalar 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 - rw [Shape.e, symCast_le_refl] + 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) σ) = + (∑ σ : Equiv.Perm (Fin lam.card), (P.e lam).coeff σ) = (P.dim lam : ℂ) * diagramSchur lam (superPS 1 0) := by classical have hfrob : ((lam.card.factorial : ℂ))⁻¹ * @@ -169,7 +170,7 @@ theorem sum_e_coeff (P : SchurPackage.{v}) (lam : YoungDiagram) : 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) σ + 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 @@ -190,7 +191,7 @@ theorem sum_e_coeff (P : SchurPackage.{v}) (lam : YoungDiagram) : 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) σ * + (∑ σ : Equiv.Perm (Fin lam.card), (P.e lam).coeff σ * ((Equiv.Perm.sign σ : ℤ) : ℂ)) = (P.dim lam : ℂ) * diagramSchur lam (superPS 0 1) := by classical @@ -213,14 +214,14 @@ theorem sum_e_coeff_sign (P : SchurPackage.{v}) 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) σ * + 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) σ = + have hc : (P.e lam).coeff σ = ((P.dim lam : ℂ) / (lam.card.factorial : ℂ)) * jtChar lam (permCast (rfl : lam.card = lam.card).symm σ) := by @@ -252,13 +253,12 @@ theorem schurKilled_of_braiding_id 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) σ * + 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) σ from + ∑ σ : 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, if_neg (by omega), mul_zero, zero_smul] - rfl /-- **Self-braiding `−1` kills every non-column Schur functor**: the central idempotent acts by the signed character sum, the Schur @@ -275,9 +275,9 @@ theorem schurKilled_of_braiding_neg 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) σ * + 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) σ * + ∑ σ : 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 @@ -288,7 +288,6 @@ theorem schurKilled_of_braiding_neg norm_num] rw [sum_e_coeff_sign, diagramSchur_superPS_col, if_neg (by omega), mul_zero, zero_smul] - rfl /-- The unit is killed at the two-cell column. -/ theorem schurKilled_unit_col diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorTransfer.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorTransfer.lean index 22e0f496e5..840c9be907 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorTransfer.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorTransfer.lean @@ -110,7 +110,7 @@ theorem pairAlg_diagEmbed (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 σ => ?_ + refine MonoidAlgebra.algHom_ext (fun σ => ?_) (Subsingleton.elim _ _) show pairAlg X Y n (diagEmbed (MonoidAlgebra.single σ 1)) = diagAlg X Y n (MonoidAlgebra.single σ 1) have hd : diagEmbed (MonoidAlgebra.single σ (1 : ℂ)) = @@ -137,7 +137,7 @@ theorem pairAlg_extFst (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n)) = (whiskerAlg (tensorPow A X n) (tensorPow A Y n)).comp (permAlg X n) := by - refine MonoidAlgebra.algHom_ext fun σ => ?_ + refine MonoidAlgebra.algHom_ext (fun σ => ?_) (Subsingleton.elim _ _) show pairAlg X Y n (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extFstHom n) (MonoidAlgebra.single σ 1)) = whiskerAlg (tensorPow A X n) (tensorPow A Y n) @@ -169,7 +169,7 @@ theorem pairAlg_extSnd (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n)) = (whiskerLeftAlg (tensorPow A X n) (tensorPow A Y n)).comp (permAlg Y n) := by - refine MonoidAlgebra.algHom_ext fun τ => ?_ + refine MonoidAlgebra.algHom_ext (fun τ => ?_) (Subsingleton.elim _ _) show pairAlg X Y n (MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n) (MonoidAlgebra.single τ 1)) = whiskerLeftAlg (tensorPow A X n) (tensorPow A Y n) @@ -243,7 +243,8 @@ theorem SchurKilled.tensorObj 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 - rw [Shape.e, symCast_le_refl] + 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 @@ -286,7 +287,6 @@ theorem SchurKilled.tensorObj exact permAlg_compat X _ _ hkilled rw [hz, MonoidalPreadditive.zero_whiskerRight, Limits.comp_zero, Limits.comp_zero] - rfl · 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 ν') = @@ -296,7 +296,6 @@ theorem SchurKilled.tensorObj exact permAlg_compat Y _ _ hkilled rw [hz, MonoidalPreadditive.whiskerLeft_zero, Limits.zero_comp, Limits.comp_zero] - rfl -- 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) : From e6aa47aea2fa23de79b821c0dd3311683955bb5e Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Tue, 22 Sep 2026 01:06:29 +0000 Subject: [PATCH 17/46] Port graded chain and adjoint compatibility through bounded lemmas --- .../Classical/Deligne/BaseChangeAdjoint.lean | 22 +++- .../RS/Classical/Deligne/ChainBGraded.lean | 65 ++++++---- .../RS/Classical/Deligne/PowPairSucc.lean | 13 +- .../RS/Classical/Deligne/Rappel210Bridge.lean | 121 +++++++++++------- .../RS/Classical/Deligne/SignConj.lean | 9 +- .../RS/Classical/Deligne/SplitTransport.lean | 2 +- .../Classical/Deligne/SuperEmbed/Letters.lean | 13 +- 7 files changed, 150 insertions(+), 95 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean index f30a11e301..e2d5dd43ad 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean @@ -63,8 +63,18 @@ theorem baseChangePair_cover simp only [Category.assoc] rfl rw [hpair] - refine Eq.trans ((reassoc_of% - (projFormula_tensorμ_cover A B φ M' M)) _) ?_ + 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 _ @@ -482,7 +492,11 @@ theorem splitCoevalDual_pair splitCoevalCoreDual A B φ v hv) ▷ (modTensor A (restrictRegular φ) M))) := associator_naturality_middle _ _ _ - refine Eq.trans (whisker_eq _ ((reassoc_of% hmid) _)) ?_ + 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 _) ?_ @@ -796,7 +810,7 @@ theorem splitCoeval_pair refine Eq.trans (whisker_eq _ (eq_whisker (congrArg (fun t => B ◁ t) (splitCoeval_point_pair A B φ w d hz hw)) _)) ?_ - rw [← BraidedCategory.braiding_naturality_left_assoc, + erw [← BraidedCategory.braiding_naturality_left_assoc, IsCommMonObj.mul_comm] rfl diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean index 16ee7411e7..35802c61eb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean @@ -214,8 +214,22 @@ noncomputable def chainBdegZeroStageIso rw [chainStage2Cast_trans] exact chainStage2Cast_rfl A M M' _ _ --- Raised budget: the graded comparison isomorphism is built from --- the colimit cocone and the duality datum in one term. +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) + [HasColimitsOfShape SmallNat.{v} D] + (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 @@ -233,15 +247,7 @@ noncomputable def chainBdegZeroIso (fun k => chainDelta2 A M M' d (0 + k) (0 + k)) (chainDelta A M M' d) (chainBdegZeroStageIso A M M') - (fun k => by - show chainDelta2 A M M' d (0 + k) (0 + k) ≫ - chainStage2Cast A M M' (Nat.zero_add (k + 1)) - (Nat.zero_add (k + 1)) = - chainStage2Cast A M M' (Nat.zero_add k) - (Nat.zero_add k) ≫ - chainDelta2 A M M' d k k - exact (chainStage2Cast_delta2 A M M' d - (Nat.zero_add k) (Nat.zero_add k)).symm) + (chainBdegZeroStage_compatibility A M M' d) end ZeroLine @@ -265,8 +271,26 @@ noncomputable def chainBdegSuccStageIso rw [chainStage2Cast_trans] exact chainStage2Cast_rfl A M M' _ _ --- Raised budget: the graded comparison isomorphism is built from --- the colimit cocone and the duality datum in one term. +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) + [HasColimitsOfShape SmallNat.{v} D] + (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. -/ @@ -287,18 +311,7 @@ noncomputable def chainBdegSuccIso (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₀) - (fun k => by - show chainDelta2 A M M' d (p₀ + 1 + k) (q₀ + 1 + k) ≫ - chainStage2Cast A M M' - (by omega : p₀ + 1 + (k + 1) = p₀ + (k + 1 + 1)) - (by omega : q₀ + 1 + (k + 1) = q₀ + (k + 1 + 1)) = - chainStage2Cast A M M' - (by omega : p₀ + 1 + k = p₀ + (k + 1)) - (by omega : q₀ + 1 + k = q₀ + (k + 1)) ≫ - chainDelta2 A M M' d (p₀ + (k + 1)) (q₀ + (k + 1)) - rw [chainStage2Cast_delta2 A M M' d - (by omega : p₀ + 1 + k = p₀ + (k + 1)) - (by omega : q₀ + 1 + k = q₀ + (k + 1))])) ≪≫ + (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)) @@ -559,7 +572,7 @@ theorem whiskerLeft_ι_chainBdegInsP chainBdegι A M M' d (p₀ + 1) q₀ k := by show (tensorLeft M'.X).map (colimit.ι (chainDiagram _ _) (smallNatEquiv.functor.obj k)) ≫ _ = _ - rw [chainBdegInsP, ι_preservesColimitIso_hom_assoc] + erw [chainBdegInsP, ι_preservesColimitIso_hom_assoc] exact colimit.ι_desc (chainBdegInsPCocone A M M' d p₀ q₀) (smallNatEquiv.functor.obj k) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairSucc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairSucc.lean index d79e6e0d2c..2453564e2e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairSucc.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairSucc.lean @@ -119,10 +119,9 @@ private theorem tensorHom_π_pairFold (modTensorπ A N₁' N₁ ⊗ₘ modTensorπ A N₂' N₂) ≫ t) t2).trans (by rw [← MonoidalCategory.tensorHom_comp_tensorHom_assoc]) - rw [← Category.assoc, tensorHom_π_interchange, - rawInterchangeπ, rawInterchange, Category.assoc, - Category.assoc] - exact congrArg (fun t : (N₁'.X ⊗ N₁.X) ⊗ (N₂'.X ⊗ N₂.X) ⟶ + 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 @@ -201,7 +200,7 @@ theorem modPowPairing_succ_tensor modPowCastMod A M.X (by omega : 0 + 1 + n + 1 = n + 2)).hom)) ≫ pairPow A M M' d (n + 2) := by - rw [← Category.assoc, + erw [← Category.assoc, MonoidalCategory.tensorHom_comp_tensorHom] -- The successor pairing against the swapped projection. have hstep : modTensorπ A (modPowMod A M.X (n + 1)) @@ -276,9 +275,9 @@ theorem modPowPairing_succ_tensor modPowCastMod A M.X (by omega : 0 + 1 + n + 1 = n + 2)).hom ⊗ₘ (powMulMod A M'.X n 0).hom) ≫ t) hstep - rw [tensorHom_π_interchange_assoc, rawInterchangeπ, - rawInterchange] + 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 ⊗ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Bridge.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Bridge.lean index 296a97b3d7..35d69ea4b7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Bridge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Bridge.lean @@ -50,8 +50,8 @@ theorem splitSeed_eq [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] show (symPowOne (𝟙_ D) Y).inv = (modPowOne (𝟙_ D) Y).inv ≫ symPowπ (𝟙_ D) Y 1 from rfl, modPowOne_inv] - simp only [Category.assoc] - exact (Category.assoc _ _ _).symm + repeat' erw [Category.assoc] + rfl /-- **The stage units are the symmetrised point powers.** -/ theorem splitUnitStage_eq @@ -80,44 +80,56 @@ theorem splitUnitStage_eq rw [← MonoidalCategory.tensorHom_comp_tensorHom, Category.assoc, symPowπ_tensor_symMul, modPowπ_tensor_modPowMul_assoc] - calc splitUnitStage Y pt (n + 1) - = (tensorPowPoint pt (n + 1) ≫ + 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 - _ = (ρ_ (𝟙_ D)).inv ≫ + 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 := 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) = + 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) := - (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 _))))) - _ = (ρ_ (𝟙_ D)).inv ≫ + 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) ≫ @@ -125,32 +137,51 @@ theorem splitUnitStage_eq (modPowπ (𝟙_ D) Y 1 ≫ symPowπ (𝟙_ D) Y 1))) ≫ symMul (𝟙_ D) Y (n + 1) 1 := by - rw [splitSeed_eq, - MonoidalCategory.tensorHom_comp_tensorHom] - rfl - _ = (ρ_ (𝟙_ D)).inv ≫ + 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] - _ = (ρ_ (𝟙_ D)).inv ≫ ((λ_ (𝟙_ D)).hom ≫ + 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] - _ = tensorPowPoint pt (n + 1 + 1) ≫ + 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 _))) + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SignConj.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SignConj.lean index 688496c177..d19e84abc0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SignConj.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SignConj.lean @@ -59,11 +59,11 @@ theorem twistPow_perm_conj (tensorPow D V (k + 1) ◁ modPowπ A R.X (k + 1)) ≫ (permMor V (k + 1) σ ⊗ₘ modPowPerm (A := A) (X := R.X) (k + 1) σ) := by - rw [← MonoidalCategory.id_tensorHom, + erw [← MonoidalCategory.id_tensorHom, MonoidalCategory.tensorHom_comp_tensorHom, MonoidalCategory.tensorHom_comp_tensorHom, Category.comp_id, Category.id_comp, modPowπ_perm] - rw [modPowπ_perm_assoc, hcov] + erw [modPowπ_perm_assoc, hcov] exact ((Category.assoc _ _ _).symm.trans ((eq_whisker h2 _).trans ((Category.assoc _ _ _).trans @@ -111,7 +111,7 @@ theorem twistPow_perm_conj_oddLine (((twistPowModIso A L.obj R k).hom).hom ≫ (tensorPow D L.obj (k + 1) ◁ modPowPerm (A := A) (X := R.X) (k + 1) σ)) := by - rw [twistPow_perm_conj, oddLine_permMor, + erw [twistPow_perm_conj, oddLine_permMor, MonoidalCategory.tensorHom_def, MonoidalLinear.smul_whiskerRight, Linear.smul_comp, MonoidalCategory.id_whiskerRight, Category.id_comp] @@ -147,7 +147,6 @@ theorem twistPow_symIdem_conj MonoidAlgebra.single σ (1 : ℂ) from by rw [MonoidAlgebra.smul_single', mul_one], map_smul, modPowAlg_single] - rfl -- The antisymmetriser's whiskered normal form, free of the -- identification. have hb : tensorPow D L.obj (k + 1) ◁ @@ -197,7 +196,7 @@ theorem twistPow_symIdem_conj 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 = _ - rw [Linear.smul_comp, Preadditive.sum_comp] + erw [Linear.smul_comp, Preadditive.sum_comp] exact congrArg _ (Finset.sum_congr rfl fun σ _ => twistPow_perm_conj_oddLine A L R k σ) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitTransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitTransport.lean index 666a793d77..ce39ef1915 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitTransport.lean @@ -49,7 +49,7 @@ theorem baseChangeFreeInv_natural rw [baseChangeMapMod_hom, baseChangeFreeInv, baseChangeFreeInv] refine Eq.trans ?_ (Eq.trans (Category.assoc _ _ _) (whisker_eq _ hmap)).symm - rw [← MonoidalCategory.whiskerLeft_comp_assoc, hcore, + erw [← MonoidalCategory.whiskerLeft_comp_assoc, hcore, MonoidalCategory.whiskerLeft_comp_assoc] rfl diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Letters.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Letters.lean index b2b2e1c787..ccc25668fe 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Letters.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Letters.lean @@ -1185,7 +1185,7 @@ noncomputable def colourSum {K : Type} [DecidableEq K] (c d : Fin n → K) : ℂ := ∑ σ ∈ Finset.univ.filter (fun σ : Equiv.Perm (Fin n) => permIndex σ c = d), - x σ * parSign σ (par ∘ c) + x.coeff σ * parSign σ (par ∘ c) /-- The colour sum vanishes between colourings of different counts. -/ @@ -1213,18 +1213,17 @@ private theorem permAlg_expand [Preadditive A] [Linear ℂ A] (X : A) {n : ℕ} (x : SymGroupAlgebra n) : - permAlg X n x = ∑ σ : Equiv.Perm (Fin n), x σ • permMor X n σ + permAlg X n x = ∑ σ : Equiv.Perm (Fin n), x.coeff σ • permMor X n σ := by classical have hlift : permAlg X n x = - x.sum fun σ r => r • permMor X n σ := by + x.coeff.sum fun σ r => r • permMor X n σ := by rw [permAlg] exact MonoidAlgebra.lift_apply _ _ - rw [hlift, show (x.sum fun σ r => r • permMor X n σ) = - ∑ σ ∈ x.support, x σ • permMor X n σ from rfl] + 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] - rfl /-- The round trip through equal colourings is the transport. -/ private theorem nIn_nOut_of_eq @@ -1257,7 +1256,7 @@ theorem nIn_permAlg_nOut else 0 := by have hstep : S.nIn n c ≫ permAlg M n x ≫ S.nOut n d = ∑ σ : Equiv.Perm (Fin n), - ((x σ * parSign σ (par ∘ c)) • + ((x.coeff σ * parSign σ (par ∘ c)) • (eqToHom (congrArg (tensorPow A U) (popCount_permIndex' σ c)) ≫ S.nIn n (permIndex σ c))) ≫ S.nOut n d := by From 39efe4ac382745042fcc0fddd5a61e5dbce5fa0d Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Tue, 22 Sep 2026 01:12:26 +0000 Subject: [PATCH 18/46] Repair graded colimit and standard letter rewrites --- .../RS/Classical/Deligne/ChainBGr.lean | 10 +++++----- .../RS/Classical/Deligne/CountableDescent.lean | 6 +++--- .../Classical/Deligne/SuperEmbed/Standard.lean | 18 +++++++++--------- 3 files changed, 17 insertions(+), 17 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean index cfc29cf170..75f2af7c3d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean @@ -296,7 +296,7 @@ theorem whiskerLeft_ι_chainBGrMulStage 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) - rw [chainBGrMulStage, ι_preservesColimitIso_hom_assoc] + erw [chainBGrMulStage, ι_preservesColimitIso_hom_assoc] exact colimit.ι_desc (chainBGrMulStageCocone A M M' d a) ⟨b⟩ /-- The stage multiplications form a cocone over the left @@ -370,7 +370,7 @@ theorem ι_whiskerRight_chainBGrMul fun a : ℤ => chainBGrComponent A M M' d a) ⟨a⟩) ≫ chainBGrMul A M M' d = chainBGrMulStage A M M' d a - rw [chainBGrMul, ι_preservesColimitIso_hom_assoc] + erw [chainBGrMul, ι_preservesColimitIso_hom_assoc] exact colimit.ι_desc (chainBGrMulCocone A M M' d) ⟨a⟩ /-- **Defining equation of the graded multiplication**: on a pair @@ -647,7 +647,7 @@ theorem chainBGr_tensorRight_hom_ext apply colimit.hom_ext intro k obtain ⟨a⟩ := k - rw [ι_preservesColimitIso_inv_assoc, + erw [ι_preservesColimitIso_inv_assoc, ι_preservesColimitIso_inv_assoc] exact w a @@ -672,7 +672,7 @@ theorem tensorLeft_chainBGr_hom_ext apply colimit.hom_ext intro k obtain ⟨b⟩ := k - rw [ι_preservesColimitIso_inv_assoc, + erw [ι_preservesColimitIso_inv_assoc, ι_preservesColimitIso_inv_assoc] exact w b @@ -1256,7 +1256,7 @@ theorem chainBGr_sandwich_hom_ext apply colimit.hom_ext intro k obtain ⟨b⟩ := k - rw [ι_preservesColimitIso_inv_assoc, + erw [ι_preservesColimitIso_inv_assoc, ι_preservesColimitIso_inv_assoc] exact w b diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescent.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescent.lean index 0e73cdc537..af4a07700f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescent.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescent.lean @@ -246,7 +246,7 @@ theorem stageMul_spec (i : A.presentation.I) : indOf.map (stageMul A i) ≫ presStage A (nextStage A i) = stageMulToAlg A i := by - rw [stageMul, CategoryTheory.Functor.map_comp, Category.assoc, + erw [stageMul, CategoryTheory.Functor.map_comp, Category.assoc, presStage_naturality, mulStageMap_spec] /-- The stages of the generated tower. -/ @@ -591,10 +591,10 @@ theorem mono_imageSubalgebraHom ⟨⟨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 - rw [Category.assoc, colimit.w, hu'] + 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 - rw [Category.assoc, colimit.w, hv'] + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean index 02ba9401b1..fdf5f85096 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean @@ -135,11 +135,11 @@ theorem sumPowIns_prj_same intro i induction i using Fin.lastCases with | last => - rw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_last, + erw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_last, Fin.lastCases_last] exact biprod.inr_snd | cast j => - rw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_castSucc, + erw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_castSucc, Fin.lastCases_castSucc] exact inl_sandwich _ _ (ih j) @@ -161,17 +161,17 @@ theorem sumPowIns_prj_ne induction i' using Fin.lastCases with | last => exact absurd rfl hii' | cast j' => - rw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_last, + erw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_last, Fin.lastCases_castSucc] exact inr_miss _ | cast j => induction i' using Fin.lastCases with | last => - rw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_castSucc, + erw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_castSucc, Fin.lastCases_last] exact inl_miss _ | cast j' => - rw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_castSucc, + erw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_castSucc, Fin.lastCases_castSucc] exact inl_sandwich_zero _ _ (ih (fun h => hii' (congrArg Fin.castSucc h))) @@ -211,9 +211,9 @@ theorem sumPow_total [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] | succ k ih => rw [Fin.sum_univ_castSucc] rw [Finset.sum_congr rfl fun j (_ : j ∈ Finset.univ) => by - rw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_castSucc, + erw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_castSucc, Fin.lastCases_castSucc]] - rw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_last, + erw [sumPowIns_succ, sumPowPrj_succ, Fin.lastCases_last, Fin.lastCases_last] exact biprod_gather (sumPowPrj X k) (sumPowIns X k) ih @@ -806,7 +806,7 @@ noncomputable def stdSuperLetters (p q : ℕ) : LinearMap.proj (R := ℂ) (φ := fun _ : Fin (q + 1) => ℂ) j') ((0 : PUnit →ₗ[ℂ] (Fin (q + 1) → ℂ)) z) = 0 - rw [LinearMap.zero_apply, map_zero] + erw [LinearMap.zero_apply, map_zero] | inr j => cases k' with | inl i' => @@ -815,7 +815,7 @@ noncomputable def stdSuperLetters (p q : ℕ) : show (LinearMap.proj (R := ℂ) (φ := fun _ : Fin (p + 1) => ℂ) i') ((0 : (Fin 0 → ℂ) →ₗ[ℂ] (Fin (p + 1) → ℂ)) z) = 0 - rw [LinearMap.zero_apply, map_zero] + rfl · refine LinearMap.ext fun z => ?_ exact Subsingleton.elim (α := PUnit) _ _ | inr j' => From 070a108969d2a74650ba65ff7ce98a14ddb38853 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Tue, 22 Sep 2026 01:16:46 +0000 Subject: [PATCH 19/46] Restore seed insertion and image algebra coherence proofs --- .../RS/Classical/Deligne/ImageSubalgebra.lean | 8 +++---- .../RS/Classical/Deligne/MixDegenerate.lean | 2 +- .../RS/Classical/Deligne/SeedIns.lean | 23 +++++++++---------- .../RS/Classical/Deligne/SuperGammaInst.lean | 3 ++- 4 files changed, 18 insertions(+), 18 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ImageSubalgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ImageSubalgebra.lean index 3ee227d5bc..4b61e9f9e2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ImageSubalgebra.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ImageSubalgebra.lean @@ -478,7 +478,7 @@ noncomputable def imageLeftMulCocone stageImageι A (towerIdx A i₀ (ULift.down m'))) = stageImageι A (towerIdx A i₀ n) ⊗ₘ stageImageι A (towerIdx A i₀ (ULift.down m)) := by - rw [whiskerLeft_comp_tensorHom, imageDiagram_map_comp_ι] + erw [whiskerLeft_comp_tensorHom, imageDiagram_map_comp_ι] rfl refine Eq.trans ?_ (Category.comp_id _).symm refine imageSubalgebra_hom_ext A i₀ ?_ @@ -526,7 +526,7 @@ theorem imageLeftMul_comp_hom imageSubalgebraHom A i₀) = stageImageι A (towerIdx A i₀ n) ⊗ₘ stageImageι A (towerIdx A i₀ (ULift.down m)) := by - rw [whiskerLeft_comp_tensorHom, imageColimitι_comp_hom] + erw [whiskerLeft_comp_tensorHom, imageColimitι_comp_hom] rfl ((Category.assoc _ _ _).symm.trans ((eq_whisker (imageLeftMul_fac A i₀ n m) _).trans @@ -550,7 +550,7 @@ noncomputable def imageMulCocone imageSubalgebraHom A i₀) = stageImageι A (towerIdx A i₀ (ULift.down n)) ⊗ₘ imageSubalgebraHom A i₀ := by - rw [whiskerRight_comp_tensorHom, imageDiagram_map_comp_ι] + erw [whiskerRight_comp_tensorHom, imageDiagram_map_comp_ι] rfl refine Eq.trans ?_ (Category.comp_id _).symm refine imageSubalgebra_hom_ext A i₀ ?_ @@ -595,7 +595,7 @@ theorem imageMul_comp_hom (imageSubalgebraHom A i₀ ⊗ₘ imageSubalgebraHom A i₀) = stageImageι A (towerIdx A i₀ (ULift.down n)) ⊗ₘ imageSubalgebraHom A i₀ := by - rw [whiskerRight_comp_tensorHom, imageColimitι_comp_hom] + erw [whiskerRight_comp_tensorHom, imageColimitι_comp_hom] rfl ((Category.assoc _ _ _).symm.trans ((eq_whisker (imageMul_fac A i₀ n) _).trans diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean index 937c1ceef8..b4633284ab 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean @@ -263,7 +263,7 @@ noncomputable def superLetters (r s : ℕ) : show (LinearMap.proj (R := ℂ) (φ := fun _ : Fin r => ℂ) i') ((0 : (Fin 0 → ℂ) →ₗ[ℂ] (Fin r → ℂ)) z) = 0 - rw [LinearMap.zero_apply, map_zero] + rfl · refine LinearMap.ext fun z => ?_ exact Subsingleton.elim (α := PUnit) _ _ | inr j' => diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean index dae2d31bcf..d86bbce6fa 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean @@ -101,7 +101,7 @@ theorem unit_chainBaseStage (λ_ (chainStage2 A M M' 0 0)).hom = (λ_ (𝟙_ D)).hom ≫ chainSeed A M M' d := leftUnitor_naturality _ - rw [chainBaseStage, reassoc_of% h1, reassoc_of% h2] + erw [chainBaseStage, reassoc_of% h1, reassoc_of% h2] exact (congrArg (fun t => (ρ_ (𝟙_ D)).inv ≫ MonoidalCategory.whiskerLeft (𝟙_ D) (Y₂ := chainStage2 A M M' 0 0) @@ -124,9 +124,8 @@ theorem chainStage2Cast_actLeft modTensorAct A (symPowMod A M'.X p) (symPowMod A M.X q) ≫ chainStage2Cast A M M' hp hq := by subst hp hq - simp only [chainStage2Cast_rfl, - MonoidalCategory.whiskerLeft_id, Category.id_comp] - exact (Category.comp_id _).symm + 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. -/ @@ -243,7 +242,7 @@ theorem chainBaseStage_mul2 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 - rw [chainBaseStage, MonoidalCategory.comp_whiskerRight, + erw [chainBaseStage, MonoidalCategory.comp_whiskerRight, MonoidalCategory.comp_whiskerRight] rfl have hb : (modTensorAct A (symPowMod A M'.X 0) @@ -1266,7 +1265,7 @@ theorem pairIns [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (symPowMod A M.X 0) ⊗ₘ modTensorπ A (symPowMod A M'.X 0) (symPowMod A M.X 0)) := by - rw [MonoidalCategory.comp_whiskerRight, Category.assoc, + erw [MonoidalCategory.comp_whiskerRight, Category.assoc, ← MonoidalCategory.tensorHom_def] have hL3 : (modTensorπ A (symPowMod A M'.X 0) (symPowMod A M.X 0) ⊗ₘ @@ -1405,7 +1404,7 @@ theorem pairIns [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (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 - simp only [MonoidalCategory.whiskerLeft_comp] + 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 ≫ @@ -1423,7 +1422,7 @@ theorem pairIns [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (eq_whisker hexp _)))).trans ?_ -- peel the five whiskers refine (whisker_eq _ (by - simp only [Category.assoc] : + 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 ▷ @@ -1709,7 +1708,7 @@ private theorem comp_chainDelta2 ((f ▷ chainStage2 A M M' 0 0) ≫ chainMul2 A M M' p q 0 0) := by rw [h2] - simp only [Category.assoc] + repeat' erw [Category.assoc] /-- **The raw pair product, normalised**: both letters braid to canonical position, the seeds feed in, and the two insertions @@ -1973,7 +1972,7 @@ private theorem swapDelta_normal (M'.X ◁ chainInsQ A M M' 0 0) ≫ (chainInsP A M M' 0 1 ≫ chainDelta2 A M M' d 1 1) := by - simp only [Category.assoc] + 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 ≫ @@ -2296,7 +2295,7 @@ private theorem pairSeed_match (M.X ◁ ((chainSeed A M M' d ▷ (chainStage2 A M M' 0 0)) ≫ chainMul2 A M M' 0 0 0 0)) := by - simp only [Category.assoc] + repeat' erw [Category.assoc] refine hre.trans ?_ refine (eq_whisker (seedShuffle A M (S := chainStage2 A M M' 0 0) @@ -2465,7 +2464,7 @@ theorem chainPairMul_eq (symPowOne A M'.X).inv from rfl, show (toSymPowModZero A M).hom = (symPowOne A M.X).inv from rfl] - simp only [Category.assoc] + repeat' erw [Category.assoc] rfl rw [hRside] exact whisker_eq _ (Category.assoc _ _ _) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean index a8e7fdee4a..baa86b50f3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean @@ -659,7 +659,8 @@ theorem smallComparison_square : superOddSquare.hom rw [smallOddSquare, Functor.FullyFaithful.preimageIso_hom, Functor.FullyFaithful.map_preimage] - simp + 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`. -/ From 8538d7e6e0bae7a2323d5f9abe0da740f4c93d43 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Tue, 22 Sep 2026 01:29:17 +0000 Subject: [PATCH 20/46] Repair pair carrier and simple quotient comparisons --- .../RegtsSevenster/RS/Classical/Deligne/PairCarrier.lean | 2 +- .../RegtsSevenster/RS/Classical/Deligne/PointFibre.lean | 4 ++-- .../RS/Classical/Deligne/SimpleQuotient.lean | 8 ++++++-- .../RS/Classical/Deligne/SplitAssemble.lean | 2 +- 4 files changed, 10 insertions(+), 6 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairCarrier.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairCarrier.lean index fc69268626..3aea43a544 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairCarrier.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairCarrier.lean @@ -90,7 +90,7 @@ theorem copairUnit_splitPairMul 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 - rw [chainBGrUnit, ← Category.assoc, + erw [chainBGrUnit, ← Category.assoc, chainBUnit_chainBGrComponentZeroIso_inv, Category.assoc] show copairUnit A M M' d ≫ chainPairMul A M M' d ≫ chainStage2Cast A M M' diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointFibre.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointFibre.lean index e19bb1aef4..4787562fad 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointFibre.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointFibre.lean @@ -262,7 +262,7 @@ theorem superVectHom_comp [FiniteDimensional ℂ (M.tensor (pointMod P)).even] ((toSuperVectEvenEquiv P N).symm ((toSuperVectEvenEquiv P N) (((tensorRightFunctor (pointMod P)).map u).evenMap ((toSuperVectEvenEquiv P M).symm x))))) - rw [LinearEquiv.symm_apply_apply] + erw [LinearEquiv.symm_apply_apply] rfl · show (toSuperVectOddEquiv P Q) (((tensorRightFunctor (pointMod P)).map (u ≫ v)).oddMap @@ -273,7 +273,7 @@ theorem superVectHom_comp [FiniteDimensional ℂ (M.tensor (pointMod P)).even] ((toSuperVectOddEquiv P N).symm ((toSuperVectOddEquiv P N) (((tensorRightFunctor (pointMod P)).map u).oddMap ((toSuperVectOddEquiv P M).symm x))))) - rw [LinearEquiv.symm_apply_apply] + erw [LinearEquiv.symm_apply_apply] rfl /-- Base change is additive. -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleQuotient.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleQuotient.lean index 3a958a670f..e135750de5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleQuotient.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleQuotient.lean @@ -312,14 +312,18 @@ instance mono_subUnionHom [SmallCategory C] [Abelian C] have h₂ : colimit.ι (subDiagram s) j ≫ (colimMap ((subCocone s).ι) ≫ (constColimitIso A).hom) = (subCocone s).ι.app j := by - rw [← Category.assoc, ι_colimMap, Category.assoc, + 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] - infer_instance + 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 -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean index 9675dc7f4a..b7db3ebb6a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean @@ -99,7 +99,7 @@ theorem splitOfBase_unit 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 - rw [chainBGrUnit, ← Category.assoc, + erw [chainBGrUnit, ← Category.assoc, chainBUnit_chainBGrComponentZeroIso_inv, Category.assoc] exact h1.trans h2.symm From 5a2af3af6dd17248a9f3acc68f48b8f81b9c28f4 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Tue, 22 Sep 2026 01:34:06 +0000 Subject: [PATCH 21/46] Repair residue monoid and odd-line simplicity proofs --- .../RS/Classical/Deligne/PointMonoidal/Residue.lean | 6 +++--- .../RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean | 9 ++++++--- .../RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean | 2 +- 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean index 35b1cc7e56..ad6847cb0d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean @@ -420,7 +420,7 @@ private theorem point_triple_ee (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))) - rw [e1, e2, e3, pointMulHom_evenMap_tmulEE, + erw [e1, e2, e3, pointMulHom_evenMap_tmulEE, pointMulHom_evenMap_tmulEE] refine ULift.ext _ _ ?_ show a.down * b.down * c.down = a.down * (b.down * c.down) @@ -468,7 +468,7 @@ theorem pointMulHom_left_unit : 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, + · conv_lhs => erw [modWhiskerRight, comp_evenMap, LinearMap.comp_apply, tensorHom_evenMap_tmulEE, pointUnitHom_evenMap, id_evenMap, LinearMap.id_coe, id_eq, pointMulHom_evenMap_tmulEE] @@ -487,7 +487,7 @@ theorem pointMulHom_right_unit : 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, + · conv_lhs => erw [modWhiskerLeft, comp_evenMap, LinearMap.comp_apply, tensorHom_evenMap_tmulEE, pointUnitHom_evenMap, id_evenMap, LinearMap.id_coe, id_eq, pointMulHom_evenMap_tmulEE] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean index 39895f231c..c7979f9881 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean @@ -393,7 +393,7 @@ theorem lineToRegular_eq_zero_iff · intro h refine Mod.hom_ext _ _ ?_ show (g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom = 0 - rw [show g.hom = 0 from congrArg Mod.Hom.hom h, + 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 @@ -433,10 +433,12 @@ theorem simple_freeMod_oddLine haveI hgm : Mono g.hom := (mono_iff_hom 𝔹 g).1 hg haveI 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 haveI hhm : Mono (lineToRegular 𝔹 L g) := by refine mono_of_mono_hom _ ?_ show Mono ((g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom) - infer_instance + exact mono_comp' hwm hrotMono constructor · intro hiso h0 haveI := hiso @@ -450,7 +452,8 @@ theorem simple_freeMod_oddLine haveI : IsIso ((g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom) := (isIso_iff_hom 𝔹 (lineToRegular 𝔹 L g)).1 inferInstance haveI : IsIso (g.hom ▷ L.obj) := - IsIso.of_isIso_comp_right _ (L.rot 𝔹).hom + @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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean index 8a36c86c83..08fb77c95c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean @@ -83,7 +83,7 @@ theorem mul_chainBaseStage (chainSeed A M M' d)) ≫ (A ◁ modTensorAct A (symPowMod A M'.X 0) (symPowMod A M.X 0)) := by - rw [chainBaseStage, MonoidalCategory.whiskerLeft_comp, + erw [chainBaseStage, MonoidalCategory.whiskerLeft_comp, MonoidalCategory.whiskerLeft_comp] rfl refine Eq.trans (eq_whisker hsplit From 16a2a242ce3b4bb2f77bc8badb4065a0067cc66c Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Tue, 22 Sep 2026 01:36:55 +0000 Subject: [PATCH 22/46] Bound transparency in residue unit-law rewrites --- .../Classical/Deligne/PointMonoidal/Residue.lean | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean index ad6847cb0d..75b3f2a5d4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean @@ -468,10 +468,10 @@ theorem pointMulHom_left_unit : refine hom_ext (fun x a => ?_) (fun u v => ?_) (fun x v => Subsingleton.elim _ _) (fun u a => Subsingleton.elim _ _) - · conv_lhs => erw [modWhiskerRight, comp_evenMap, - LinearMap.comp_apply, tensorHom_evenMap_tmulEE, - pointUnitHom_evenMap, id_evenMap, LinearMap.id_coe, id_eq, - pointMulHom_evenMap_tmulEE] + · 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] @@ -487,10 +487,10 @@ theorem pointMulHom_right_unit : refine hom_ext (fun a x => ?_) (fun v u => ?_) (fun a u => Subsingleton.elim _ _) (fun v x => Subsingleton.elim _ _) - · conv_lhs => erw [modWhiskerLeft, comp_evenMap, - LinearMap.comp_apply, tensorHom_evenMap_tmulEE, - pointUnitHom_evenMap, id_evenMap, LinearMap.id_coe, id_eq, - pointMulHom_evenMap_tmulEE] + · 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 _ _) From 956910bf903b698d0682258d7766612384d5edee Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Tue, 22 Sep 2026 01:41:30 +0000 Subject: [PATCH 23/46] Port residue comparison inverse laws to current coercion transparency --- .../Deligne/PointMonoidal/Coherence.lean | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean index b2f01c6c0f..92af9d4819 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean @@ -674,8 +674,8 @@ theorem baseNuEven_muRaw_inl : (N.tensor (pointMod P)) (tmulEE M (pointMod P) m a ⊗ₜ[ℂ] tmulEE N (pointMod P) n b, 0))) = _ - rw [gradedTensorEven_ee, pointBaseMu_evenMap_ee, - baseNuEven_tmulEE, baseNuInnerEven_tmulEE, baseNuFee_apply] + rw [gradedTensorEven_ee, pointBaseMu_evenMap_ee] + erw [baseNuEven_tmulEE, baseNuInnerEven_tmulEE, baseNuFee_apply] show (a.down * b.down) • _ = _ rw [tmulEE_point_eq_smul P m a, tmulEE_point_eq_smul P n b] exact smulPairInl _ _ _ _ @@ -703,8 +703,8 @@ theorem baseNuEven_muRaw_inr : (N.tensor (pointMod P)) (0, tmulOE M (pointMod P) m a ⊗ₜ[ℂ] tmulOE N (pointMod P) n b))) = _ - rw [gradedTensorEven_oo, pointBaseMu_evenMap_oo, - baseNuEven_tmulEE, baseNuInnerEven_tmulOO, baseNuFoo_apply] + rw [gradedTensorEven_oo, pointBaseMu_evenMap_oo] + erw [baseNuEven_tmulEE, baseNuInnerEven_tmulOO, baseNuFoo_apply] show (a.down * b.down) • _ = _ rw [tmulOE_point_eq_smul P m a, tmulOE_point_eq_smul P n b] exact smulPairInr _ _ _ _ @@ -729,8 +729,8 @@ theorem baseNuOdd_muRaw_inl : (N.tensor (pointMod P)) (tmulEE M (pointMod P) m a ⊗ₜ[ℂ] tmulOE N (pointMod P) n b, 0))) = _ - rw [gradedTensorOdd_eo, pointBaseMu_oddMap_eo, - baseNuOdd_tmulOE, baseNuInnerOdd_tmulEO, baseNuFeo_apply] + rw [gradedTensorOdd_eo, pointBaseMu_oddMap_eo] + erw [baseNuOdd_tmulOE, baseNuInnerOdd_tmulEO, baseNuFeo_apply] show (a.down * b.down) • _ = _ rw [tmulEE_point_eq_smul P m a, tmulOE_point_eq_smul P n b] exact smulPairInl _ _ _ _ @@ -756,8 +756,8 @@ theorem baseNuOdd_muRaw_inr : (N.tensor (pointMod P)) (0, tmulOE M (pointMod P) m a ⊗ₜ[ℂ] tmulEE N (pointMod P) n b))) = _ - rw [gradedTensorOdd_oe, pointBaseMu_oddMap_oe, - baseNuOdd_tmulOE, baseNuInnerOdd_tmulOE, baseNuFoe_apply] + rw [gradedTensorOdd_oe, pointBaseMu_oddMap_oe] + erw [baseNuOdd_tmulOE, baseNuInnerOdd_tmulOE, baseNuFoe_apply] show (a.down * b.down) • _ = _ rw [tmulOE_point_eq_smul P m a, tmulEE_point_eq_smul P n b] exact smulPairInr _ _ _ _ From a30d864c6e388d9111cf5a85c57b4881b3dfab52 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Tue, 22 Sep 2026 01:45:22 +0000 Subject: [PATCH 24/46] Restore compiled statement and definition contracts for Regts Sevenster --- .../RS/Assembly/BlueprintStatement.lean | 533 ++++++++++++++---- 1 file changed, 422 insertions(+), 111 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean index d67200c4fa..fd10259b49 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean @@ -19,7 +19,7 @@ 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 `#guard_msgs` turns a change to a pinned type into a compile +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 @@ -42,6 +42,13 @@ trusts. `RS/DimensionDefinitions.lean` adds the growth, minimum and prescribed-dimension surface and imports only that main surface. -/ +noncomputable section + +universe u v u_1 u_2 + +open CategoryTheory +open scoped BigOperators + namespace RS /-! ## The model @@ -50,13 +57,33 @@ 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 audit output: Fragment : Type → Type 1 -/ +/- Upstream contract: +Fragment : Type → Type 1 +-/ +example : Type → Type 1 := + @Fragment -/- Upstream audit output: ClosedFragment : Type 1 -/ -/- Upstream audit output: emptyClosedFragment : ClosedFragment -/ +/- 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 -/- Upstream audit output: @Fragment.Equiv : {α : Type} → Fragment α → Fragment α → Type -/ /-! ## Mixed partition functions @@ -65,23 +92,53 @@ 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 audit output: MixedFunctional : ℕ → ℕ → Type -/ +/- Upstream contract: +MixedFunctional : ℕ → ℕ → Type +-/ +example : ℕ → ℕ → Type := + @MixedFunctional + + +/- Upstream contract: +@mixedPartition : {α : Type} → {k ℓ : ℕ} → MixedFunctional k ℓ → Fragment α → ℂ +-/ +example : {α : Type} → {k ℓ : ℕ} → MixedFunctional k ℓ → Fragment α → ℂ := + @mixedPartition -/- Upstream audit output: @mixedPartition : {α : Type} → {k ℓ : ℕ} → MixedFunctional k ℓ → Fragment α → ℂ -/ -/- Upstream audit output: IsMixedPartitionFunction : (ClosedFragment → ℂ) → Prop -/ +/- Upstream contract: +IsMixedPartitionFunction : (ClosedFragment → ℂ) → Prop +-/ +example : (ClosedFragment → ℂ) → Prop := + @IsMixedPartitionFunction -/- Upstream audit output: IsMixedPartitionFunctionBounded : (ClosedFragment → ℂ) → ℕ → Prop -/ -/- Upstream audit output: TotalBoundedMixedModel : (ClosedFragment → ℂ) → ℕ → Type -/ +/- 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 -/- Upstream audit output: IsMixedPartitionFunctionTotalBounded : (ClosedFragment → ℂ) → ℕ → Prop -/ /-! The total bound is pinned by content: its witness bounds the sum of both dimensions and evaluates to the original parameter. -/ -/-- -info: structure RS.TotalBoundedMixedModel (f : ClosedFragment → ℂ) (B : ℕ) : Type +/- Upstream contract: +structure RS.TotalBoundedMixedModel (f : ClosedFragment → ℂ) (B : ℕ) : Type number of parameters: 2 fields: RS.TotalBoundedMixedModel.k : ℕ @@ -94,11 +151,18 @@ constructor: (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 + -/-- -info: def RS.IsMixedPartitionFunctionTotalBounded : (ClosedFragment → ℂ) → ℕ → Prop := +/- 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 @@ -106,26 +170,63 @@ fun (f : ClosedFragment → ℂ) (B : ℕ) => Nonempty (TotalBoundedMixedModel f at most `R ^ t` at every arity `t`; `EdgeRankParameter R` packages a normalized, isomorphism-invariant parameter with that bound. -/ -/- Upstream audit output: EdgeRankBounded : (ClosedFragment → ℂ) → ℕ → Prop -/ +/- Upstream contract: +EdgeRankBounded : (ClosedFragment → ℂ) → ℕ → Prop +-/ +example : (ClosedFragment → ℂ) → ℕ → Prop := + @EdgeRankBounded + + +/- Upstream contract: +EdgeRankParameter : ℕ → Type 1 +-/ +example : ℕ → Type 1 := + @EdgeRankParameter -/- Upstream audit output: EdgeRankParameter : ℕ → Type 1 -/ /-! ## The statements and Deligne's theorem -/ -/- Upstream audit output: RegtsSevensterStatement : Prop -/ +/- Upstream contract: +RegtsSevensterStatement : Prop +-/ +example : Prop := + @RegtsSevensterStatement + -/- Upstream audit output: RegtsSevensterStatementQuant : Prop -/ +/- Upstream contract: +RegtsSevensterStatementQuant : Prop +-/ +example : Prop := + @RegtsSevensterStatementQuant -/- Upstream audit output: RegtsSevensterStatementTotal : Prop -/ -/-- -info: def RS.RegtsSevensterStatementTotal : Prop := +/- 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 audit output: RegtsSevensterConverseStatement : Prop -/ -/- Upstream audit output: DeligneTheoremStatement : Prop -/ +/- Upstream contract: +DeligneTheoremStatement : Prop +-/ +example : Prop := + @DeligneTheoremStatement.{u, v} + /-! ### Deligne's theorem, unfolded @@ -138,8 +239,8 @@ of it is a compile error. The statement is proved in of this tree rather than of an assumption. -/ -/-- -info: def RS.HasScalarUnit.{v, u} : (A : Type u) → +/- 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 := @@ -148,36 +249,63 @@ fun (A : Type u) [CategoryTheory.Category.{v, u} A] [CategoryTheory.Preadditive 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 -/-- -info: tensorPow_zero : ∀ (A : Type u_2) [inst : CategoryTheory.Category.{u_1, u_2} A] + +/- 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 -/-- -info: tensorPow_succ : ∀ (A : Type u_2) [inst : CategoryTheory.Category.{u_1, u_2} A] + +/- 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 -/-- -info: def RS.mixedPow.{v, u} : (A : Type u) → + +/- 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 + -/-- -info: def RS.IsSubquotientOf.{v, u} : {C : Type u} → [CategoryTheory.Category.{v, u} C] → C → C → Prop := +/- 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 -/-- -info: def RS.TensorGeneratedBy.{v, u} : (A : Type u) → + +/- 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] → @@ -186,22 +314,37 @@ fun (A : Type u) [CategoryTheory.Category.{v, u} A] [CategoryTheory.MonoidalCate [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 + -/-- -info: def RS.LengthLE.{v, u} : {C : Type u} → [CategoryTheory.Category.{v, u} C] → C → ℕ → Prop := +/- 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 -/-- -info: def RS.ModerateLengthGrowth.{v, u} : (A : Type u) → + +/- 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 + -/-- -info: structure RS.DeligneFibreFunctor.{u_1, u_2} (A : Type u_1) [CategoryTheory.Category.{u_2, u_1} A] +/- 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 @@ -221,9 +364,18 @@ constructor: (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 -/-- -info: def RS.DeligneTheoremStatement.{u, v} : Prop := + +/- 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] @@ -231,45 +383,94 @@ info: def RS.DeligneTheoremStatement.{u, v} : Prop := [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 audit output: regts_sevenster_converse : RegtsSevensterConverseStatement -/ +/- Upstream contract: +regts_sevenster_converse : RegtsSevensterConverseStatement +-/ +example : RegtsSevensterConverseStatement := + @regts_sevenster_converse -/- Upstream audit output: regts_sevenster_deligne_only : DeligneTheoremStatement → RegtsSevensterStatement -/ -/-- -info: regts_sevenster_quant_deligne_only : DeligneTheoremStatement → RegtsSevensterStatementQuant +/- Upstream contract: +regts_sevenster_deligne_only : DeligneTheoremStatement → RegtsSevensterStatement -/ +example : DeligneTheoremStatement.{1, 1} → RegtsSevensterStatement := + @regts_sevenster_deligne_only -/- Upstream audit output: regts_sevenster_total_deligne_only : DeligneTheoremStatement → RegtsSevensterStatementTotal -/ -/- Upstream audit output: regts_sevenster_total : RegtsSevensterStatementTotal -/ +/- Upstream contract: +regts_sevenster_quant_deligne_only : DeligneTheoremStatement → RegtsSevensterStatementQuant +-/ +example : DeligneTheoremStatement.{1, 1} → RegtsSevensterStatementQuant := + @regts_sevenster_quant_deligne_only + -/-- -info: @edgeRankBounded_of_mixedBounded : ∀ {f : ClosedFragment → ℂ} {B : ℕ}, +/- 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 -/-- -info: regts_sevenster_iff : DeligneTheoremStatement → + +/- 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 -/-- -info: regts_sevenster_quant_roundtrip : DeligneTheoremStatement → + +/- 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 @@ -289,132 +490,236 @@ 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 audit output: loopGraph : ClosedFragment -/ +/- Upstream contract: +loopGraph : ClosedFragment +-/ +example : ClosedFragment := + @loopGraph + + +/- Upstream contract: +charPolyFunctional : ℂ → MixedFunctional 2 1 +-/ +example : ℂ → MixedFunctional 2 1 := + @charPolyFunctional -/- Upstream audit output: charPolyFunctional : ℂ → MixedFunctional 2 1 -/ -/- Upstream audit output: mixedPartition_loopGraph : ∀ (θ : ℂ), mixedPartition (charPolyFunctional θ) loopGraph = θ - 2 -/ +/- 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 -/- Upstream audit output: mixedPartition_loopGraphCircle : ∀ (θ : ℂ), mixedPartition (charPolyFunctional θ) loopGraphCircle = 0 -/ /-! ## Minimum dimensions, rank growth and padding -/ -/-- -info: circlesClosed : ℕ → ClosedFragment +/- Upstream contract: +circlesClosed : ℕ → ClosedFragment -/ +example : ℕ → ClosedFragment := + @circlesClosed -/-- -info: connectionRank : (ClosedFragment → ℂ) → ℕ → ℕ + +/- Upstream contract: +connectionRank : (ClosedFragment → ℂ) → ℕ → ℕ -/ +example : (ClosedFragment → ℂ) → ℕ → ℕ := + @connectionRank + -/-- -info: @MixedFunctional.Represents : {k ℓ : ℕ} → MixedFunctional k ℓ → (ClosedFragment → ℂ) → Prop +/- Upstream contract: +@MixedFunctional.Represents : {k ℓ : ℕ} → MixedFunctional k ℓ → (ClosedFragment → ℂ) → Prop -/ +example : {k ℓ : ℕ} → MixedFunctional k ℓ → (ClosedFragment → ℂ) → Prop := + @MixedFunctional.Represents -/-- -info: minimumColourDimension : (ClosedFragment → ℂ) → ℕ + +/- Upstream contract: +minimumColourDimension : (ClosedFragment → ℂ) → ℕ -/ +example : (ClosedFragment → ℂ) → ℕ := + @minimumColourDimension + -/-- -info: PrescribedColourBounds : (ClosedFragment → ℂ) → ℕ → ℕ → Prop +/- Upstream contract: +PrescribedColourBounds : (ClosedFragment → ℂ) → ℕ → ℕ → Prop -/ +example : (ClosedFragment → ℂ) → ℕ → ℕ → Prop := + @PrescribedColourBounds -/-- -info: @regts_sevenster_minimum : ∀ {R : ℕ} (f : EdgeRankParameter R), + +/- 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 + -/-- -info: @regts_sevenster_rank_growth : ∀ {R : ℕ} (f : EdgeRankParameter R), - Filter.Tendsto (fun n => ↑(connectionRank f.val (2 * n)) ^ (↑(2 * n))⁻¹) Filter.atTop +/- 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 -/-- -info: regts_sevenster_prescribed : ∀ (f : ClosedFragment → ℂ), + +/- Upstream contract: +regts_sevenster_prescribed : ∀ (f : ClosedFragment → ℂ), f emptyClosedFragment = 1 → (∀ (W₁ W₂ : ClosedFragment) (a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → - ∀ (k ℓ : ℕ), (∃ h, h.Represents f) ↔ PrescribedColourBounds f k ℓ + ∀ (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 + -/-- -info: regts_sevenster_minimum_deligne_only : DeligneTheoremStatement → +/- 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 -/-- -info: regts_sevenster_rank_growth_deligne_only : DeligneTheoremStatement → + +/- 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 + 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 -/-- -info: regts_sevenster_prescribed_deligne_only : DeligneTheoremStatement → + +/- 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, h.Represents f) ↔ PrescribedColourBounds f K L + ∀ (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 -/-- -info: @minimumColourDimension_le_of_represents : ∀ {f : ClosedFragment → ℂ} {k ℓ : ℕ} (h : MixedFunctional k ℓ), + +/- 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 + -/-- -info: @TotalBoundedMixedModel.dimension_eq_minimum : ∀ {f : ClosedFragment → ℂ} +/- 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 -/-- -info: @TotalBoundedMixedModel.even_dimension_eq : ∀ {f : ClosedFragment → ℂ} + +/- 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 -/-- -info: @TotalBoundedMixedModel.half_odd_dimension_eq : ∀ {f : ClosedFragment → ℂ} + +/- 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 -/-- -info: @MixedFunctional.padColours : {k ℓ K L : ℕ} → MixedFunctional k ℓ → k ≤ K → ℓ ≤ L → MixedFunctional K L + +/- 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 + -/-- -info: @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 +/- 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 -/-- -info: @connectionRank_cast_eq_rank : ∀ {R : ℕ} (f : EdgeRankParameter R) (t : ℕ), + +/- 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 + -/-- -info: def RS.circlesClosed : ℕ → ClosedFragment := +/- 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 -/-- -info: def RS.connectionRank : (ClosedFragment → ℂ) → ℕ → ℕ := + +/- 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 + -/-- -info: def RS.MixedFunctional.Represents : {k ℓ : ℕ} → MixedFunctional k ℓ → (ClosedFragment → ℂ) → Prop := +/- 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 -/-- -info: def RS.minimumColourDimension : (ClosedFragment → ℂ) → ℕ := + +/- Upstream contract: +def RS.minimumColourDimension : (ClosedFragment → ℂ) → ℕ := fun f => sInf {d | IsMixedPartitionFunctionTotalBounded f d} -/ +example : @minimumColourDimension = (fun f => sInf {d | IsMixedPartitionFunctionTotalBounded f d} : (ClosedFragment → ℂ) → ℕ) := rfl + -/-- -info: structure RS.PrescribedColourBounds (f : ClosedFragment → ℂ) (k ℓ : ℕ) : Prop +/- Upstream contract: +structure RS.PrescribedColourBounds (f : ClosedFragment → ℂ) (k ℓ : ℕ) : Prop number of parameters: 3 fields: RS.PrescribedColourBounds.circle_eq : f (circlesClosed 1) = ↑k - 2 * ↑ℓ @@ -423,5 +728,11 @@ 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 From 319ff568082ea381cff0f7f354f1995e4549d720 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Fri, 25 Sep 2026 08:21:34 +0000 Subject: [PATCH 25/46] Refactor Regts proofs within quality limits and resolve compiler warnings --- .../RS/Assembly/BlueprintStatement.lean | 44 +- .../RS/Classical/Algebra/FactorialTrace.lean | 2 +- .../RS/Classical/Algebra/TraceCriterion.lean | 2 +- .../RS/Classical/CatTheory/Growth.lean | 4 +- .../RS/Classical/CatTheory/KaroubiLinear.lean | 4 +- .../RS/Classical/CatTheory/KaroubiTrace.lean | 2 +- .../RS/Classical/CatTheory/Length.lean | 8 +- .../RS/Classical/CatTheory/LengthBound.lean | 18 +- .../RS/Classical/CatTheory/PartialTrace.lean | 10 +- .../RS/Classical/CatTheory/Trace.lean | 18 +- .../Classical/Deligne/BaseChangeAdjoint.lean | 4 +- .../Classical/Deligne/BaseChangeBiprod.lean | 19 +- .../Deligne/BaseChangeCoherence.lean | 9 +- .../RS/Classical/Deligne/BaseChangeDatum.lean | 4 +- .../Classical/Deligne/BaseChangeLinear.lean | 2 +- .../Classical/Deligne/BaseChangeMonoidal.lean | 4 +- .../Classical/Deligne/BaseChangeTensor.lean | 4 +- .../Deligne/BaseChangeTransport.lean | 8 +- .../RS/Classical/Deligne/BigTensor.lean | 32 +- .../RS/Classical/Deligne/BiprodPow.lean | 8 +- .../RS/Classical/Deligne/BiprodTransfer.lean | 40 +- .../RS/Classical/Deligne/BlockUnits.lean | 22 +- .../RS/Classical/Deligne/ChainAlgebra.lean | 12 +- .../RS/Classical/Deligne/ChainBGr.lean | 8 +- .../RS/Classical/Deligne/ChainBGraded.lean | 10 +- .../RS/Classical/Deligne/ChainBridge.lean | 43 +- .../RS/Classical/Deligne/ChainDelta.lean | 4 +- .../RS/Classical/Deligne/ChainIns/Base.lean | 6 +- .../Classical/Deligne/ChainIns/FirstSlot.lean | 320 +++- .../Deligne/ChainIns/SecondSlot.lean | 442 ++++- .../RS/Classical/Deligne/ChainMul.lean | 6 +- .../RS/Classical/Deligne/ChainMulHet.lean | 8 +- .../RS/Classical/Deligne/ChainMulLaws.lean | 271 ++- .../RS/Classical/Deligne/ChainShift.lean | 2 +- .../RS/Classical/Deligne/ChainStage2.lean | 294 ++-- .../RS/Classical/Deligne/CharSplit.lean | 12 +- .../RS/Classical/Deligne/CommonAlgebra.lean | 4 +- .../RS/Classical/Deligne/CoprodPreserve.lean | 22 +- .../Classical/Deligne/CountableDescent.lean | 2 +- .../Deligne/CountableDescentClose.lean | 20 +- .../Deligne/CountableNullstellensatz.lean | 8 +- .../RS/Classical/Deligne/CoverFactor.lean | 128 +- .../RS/Classical/Deligne/CycleSplit.lean | 7 +- .../RS/Classical/Deligne/DayCalculus.lean | 10 +- .../RS/Classical/Deligne/DeligneAssembly.lean | 26 +- .../RS/Classical/Deligne/DevissageBound.lean | 4 +- .../RS/Classical/Deligne/DoubledGrowth.lean | 10 +- .../RS/Classical/Deligne/DoubledSplit.lean | 8 +- .../RS/Classical/Deligne/Doubling.lean | 87 +- .../Classical/Deligne/EvenEmbedMonoidal.lean | 4 +- .../RS/Classical/Deligne/FibreAdditive.lean | 4 +- .../RS/Classical/Deligne/FibreExact.lean | 10 +- .../RS/Classical/Deligne/FibreFaithful.lean | 12 +- .../RS/Classical/Deligne/FibreFunctor.lean | 4 +- .../RS/Classical/Deligne/FibreLinear.lean | 4 +- .../RS/Classical/Deligne/FibreMu.lean | 4 +- .../RS/Classical/Deligne/FibreMuNat.lean | 2 +- .../Classical/Deligne/FibreOverComplex.lean | 36 +- .../Classical/Deligne/FibreOverSplitting.lean | 14 +- .../RS/Classical/Deligne/FiltNil.lean | 6 +- .../RS/Classical/Deligne/FlatLimit.lean | 6 +- .../RS/Classical/Deligne/FreeMixRetract.lean | 2 +- .../RS/Classical/Deligne/FreeModAdjoint.lean | 2 +- .../RS/Classical/Deligne/FreeModShuffle.lean | 12 +- .../RS/Classical/Deligne/FreeModTensor.lean | 4 +- .../Classical/Deligne/FreeNormaliseStep.lean | 4 +- .../RS/Classical/Deligne/FreePow.lean | 6 +- .../RS/Classical/Deligne/FreePowDesc.lean | 14 +- .../RS/Classical/Deligne/FreePowInsert.lean | 10 +- .../RS/Classical/Deligne/FreeSlide.lean | 10 +- .../RS/Classical/Deligne/FreeSummand.lean | 76 +- .../RS/Classical/Deligne/FreeTwistPi.lean | 4 +- .../RS/Classical/Deligne/GammaComplex.lean | 4 +- .../RS/Classical/Deligne/GammaCountable.lean | 26 +- .../Classical/Deligne/GammaModuleFunctor.lean | 4 +- .../RS/Classical/Deligne/GammaPair.lean | 16 +- .../RS/Classical/Deligne/GammaPairAdd.lean | 4 +- .../RS/Classical/Deligne/GammaPairNat.lean | 8 +- .../Classical/Deligne/GammaPairRetract.lean | 2 +- .../Deligne/GammaPairRetractRight.lean | 2 +- .../RS/Classical/Deligne/GammaTwistLeft.lean | 12 +- .../Classical/Deligne/GeneratorAlgebra.lean | 8 +- .../RS/Classical/Deligne/HomFinite.lean | 30 +- .../RS/Classical/Deligne/HookMult.lean | 2 +- .../RS/Classical/Deligne/HookZero.lean | 46 +- .../RS/Classical/Deligne/IdemCut.lean | 4 +- .../Classical/Deligne/IdempotentLength.lean | 2 +- .../RS/Classical/Deligne/ImageSubalgebra.lean | 4 +- .../RS/Classical/Deligne/IndCoeq.lean | 96 +- .../RS/Classical/Deligne/IndCompact.lean | 2 +- .../RS/Classical/Deligne/IndImage.lean | 6 +- .../RS/Classical/Deligne/IndKill.lean | 25 +- .../RS/Classical/Deligne/IndLocallyMixed.lean | 6 +- .../RS/Classical/Deligne/IndMonoidal.lean | 2 +- .../RS/Classical/Deligne/IndOfLinear.lean | 12 +- .../RS/Classical/Deligne/IndSchur.lean | 14 +- .../RS/Classical/Deligne/IndSchurKilled.lean | 12 +- .../RS/Classical/Deligne/IndSimple.lean | 12 +- .../RS/Classical/Deligne/IndSplit.lean | 6 +- .../RS/Classical/Deligne/IndSplitSection.lean | 8 +- .../RS/Classical/Deligne/IndTensorExact.lean | 128 +- .../RS/Classical/Deligne/InitDatum.lean | 4 +- .../RS/Classical/Deligne/InterchangeAct.lean | 6 +- .../RS/Classical/Deligne/KernelPow.lean | 26 +- .../RS/Classical/Deligne/KeyLemmaClose.lean | 2 +- .../RS/Classical/Deligne/KronKill.lean | 20 +- .../RS/Classical/Deligne/LambdaCoend.lean | 35 +- .../RS/Classical/Deligne/MixDegenerate.lean | 20 +- .../RS/Classical/Deligne/MixWhisker.lean | 2 +- .../RS/Classical/Deligne/MixedConc.lean | 18 +- .../RS/Classical/Deligne/MixedDiag.lean | 4 +- .../RS/Classical/Deligne/ModAbelian.lean | 52 +- .../RS/Classical/Deligne/ModAssoc.lean | 12 +- .../RS/Classical/Deligne/ModBiprod.lean | 12 +- .../RS/Classical/Deligne/ModContractL.lean | 10 +- .../RS/Classical/Deligne/ModCross.lean | 26 +- .../RS/Classical/Deligne/ModDual.lean | 10 +- .../RS/Classical/Deligne/ModIns.lean | 14 +- .../RS/Classical/Deligne/ModMulti.lean | 36 +- .../RS/Classical/Deligne/ModMultiTriple.lean | 19 +- .../RS/Classical/Deligne/ModPowDescent.lean | 2 +- .../RS/Classical/Deligne/ModPowStage.lean | 4 +- .../RS/Classical/Deligne/ModSchurSummand.lean | 10 +- .../RS/Classical/Deligne/ModTensor.lean | 28 +- .../RS/Classical/Deligne/NewtonConv.lean | 3 +- .../RS/Classical/Deligne/NullPoint.lean | 8 +- .../RS/Classical/Deligne/OddLinePairing.lean | 4 +- .../RS/Classical/Deligne/OddParity.lean | 8 +- .../RS/Classical/Deligne/OddSquare.lean | 2 +- .../RS/Classical/Deligne/OddSquareIso.lean | 30 +- .../RS/Classical/Deligne/PairCarrier.lean | 2 +- .../RS/Classical/Deligne/PairMul.lean | 8 +- .../RS/Classical/Deligne/PairPerm.lean | 10 +- .../RS/Classical/Deligne/PermNat.lean | 38 +- .../RS/Classical/Deligne/PermRepChar.lean | 27 +- .../RS/Classical/Deligne/PieriPos.lean | 197 ++- .../RS/Classical/Deligne/PointBaseChange.lean | 9 +- .../RS/Classical/Deligne/PointFibre.lean | 50 +- .../Deligne/PointMonoidal/Calculus.lean | 4 +- .../Deligne/PointMonoidal/Coherence.lean | 291 +-- .../Deligne/PointMonoidal/Comparison.lean | 24 +- .../Deligne/PointMonoidal/Functor.lean | 8 +- .../Deligne/PointMonoidal/Residue.lean | 28 +- .../RS/Classical/Deligne/PointTensor.lean | 12 +- .../RS/Classical/Deligne/PowChain.lean | 4 +- .../RS/Classical/Deligne/PowInduct.lean | 4 +- .../RS/Classical/Deligne/PowMerge.lean | 4 +- .../RS/Classical/Deligne/PowPairSucc.lean | 292 ++- .../RS/Classical/Deligne/PowPairing.lean | 38 +- .../RS/Classical/Deligne/PowPoint.lean | 10 +- .../RS/Classical/Deligne/PowSucc.lean | 2 +- .../RS/Classical/Deligne/PowSuccMod.lean | 10 +- .../RS/Classical/Deligne/PowTriangle.lean | 23 +- .../RS/Classical/Deligne/PowZig.lean | 4 +- .../Classical/Deligne/PresentedQuotient.lean | 26 +- .../RS/Classical/Deligne/Prop21.lean | 16 +- .../RS/Classical/Deligne/Prop21Core.lean | 8 +- .../RS/Classical/Deligne/Prop21General.lean | 20 +- .../RS/Classical/Deligne/Prop29State.lean | 8 +- .../RS/Classical/Deligne/Rappel210Chain.lean | 6 +- .../RS/Classical/Deligne/Rappel210Close.lean | 4 +- .../RS/Classical/Deligne/Rappel210Ind.lean | 2 +- .../RS/Classical/Deligne/Rappel210Reduce.lean | 28 +- .../RS/Classical/Deligne/RegularSum.lean | 46 +- .../RS/Classical/Deligne/RhoBiprod.lean | 2 +- .../RS/Classical/Deligne/RowColIdem.lean | 28 +- .../RS/Classical/Deligne/SandwichZig.lean | 2 +- .../RS/Classical/Deligne/ScalarBraiding.lean | 14 +- .../RS/Classical/Deligne/ScalarLinear.lean | 34 +- .../RS/Classical/Deligne/ScalarUnitEquiv.lean | 2 +- .../RS/Classical/Deligne/ScalarUnitInd.lean | 8 +- .../RS/Classical/Deligne/SchurTransport.lean | 10 +- .../RS/Classical/Deligne/SeedIns.lean | 182 +- .../RS/Classical/Deligne/SignConj.lean | 4 +- .../RS/Classical/Deligne/SimpleGenerator.lean | 18 +- .../RS/Classical/Deligne/SimplePoint.lean | 2 +- .../RS/Classical/Deligne/SimpleQuotient.lean | 40 +- .../RS/Classical/Deligne/SimpleScalars.lean | 20 +- .../RS/Classical/Deligne/SimpleSplit.lean | 86 +- .../RS/Classical/Deligne/SmallReduction.lean | 47 +- .../RS/Classical/Deligne/SplitAssemble.lean | 121 +- .../RS/Classical/Deligne/SplitClosure.lean | 4 +- .../RS/Classical/Deligne/SplitComplement.lean | 10 +- .../RS/Classical/Deligne/SplitEverything.lean | 20 +- .../RS/Classical/Deligne/SplitExtract.lean | 4 +- .../Classical/Deligne/SplitExtractDual.lean | 10 +- .../RS/Classical/Deligne/SplitMonHom.lean | 2 +- .../RS/Classical/Deligne/SplitPairDef.lean | 4 +- .../RS/Classical/Deligne/SplitTransport.lean | 2 +- .../RS/Classical/Deligne/StepA.lean | 10 +- .../RS/Classical/Deligne/StepATransport.lean | 4 +- .../RS/Classical/Deligne/StepB.lean | 4 +- .../Classical/Deligne/SuperEmbed/Letters.lean | 28 +- .../Classical/Deligne/SuperEmbed/Signs.lean | 12 +- .../Deligne/SuperEmbed/Standard.lean | 67 +- .../RS/Classical/Deligne/SuperEvenRing.lean | 6 +- .../RS/Classical/Deligne/SuperGamma.lean | 26 +- .../RS/Classical/Deligne/SuperGammaInst.lean | 18 +- .../RS/Classical/Deligne/SuperModAbelian.lean | 2 +- .../Classical/Deligne/SuperModBiprodMap.lean | 8 +- .../RS/Classical/Deligne/SuperModHom.lean | 12 +- .../Classical/Deligne/SuperModMonoidal.lean | 8 +- .../Classical/Deligne/SuperModShiftUnit.lean | 34 +- .../RS/Classical/Deligne/SuperModTensor.lean | 16 +- .../RS/Classical/Deligne/SuperPointMod.lean | 10 +- .../RS/Classical/Deligne/SuperRealize.lean | 36 +- .../RS/Classical/Deligne/SuperSeries.lean | 2 +- .../RS/Classical/Deligne/SuperSmall.lean | 38 +- .../RS/Classical/Deligne/SuperVectSchur.lean | 149 +- .../RS/Classical/Deligne/SymAlg.lean | 6 +- .../RS/Classical/Deligne/SymDatum.lean | 12 +- .../RS/Classical/Deligne/SymMul.lean | 25 +- .../RS/Classical/Deligne/TensorDatum.lean | 4 +- .../RS/Classical/Deligne/TensorTransfer.lean | 18 +- .../RS/Classical/Deligne/TensorZigzag.lean | 545 +++--- .../RS/Classical/Deligne/TrichotomyClose.lean | 4 +- .../RS/Classical/Deligne/TwistBiprod.lean | 6 +- .../RS/Classical/Deligne/TwistFreeTensor.lean | 12 +- .../RS/Classical/Deligne/TwistShuffle.lean | 24 +- .../RS/Classical/Deligne/TwistUnitor.lean | 16 +- .../RS/Classical/Deligne/UnitBase.lean | 8 +- .../RS/Classical/Deligne/UnitSimple.lean | 70 +- .../Classical/Deligne/UniversalAlgebra.lean | 8 +- .../RS/Classical/Deligne/WhiskerFaithful.lean | 10 +- .../RS/Classical/Deligne/WordMap.lean | 6 +- .../RS/Classical/Deligne/ZigzagCarrier.lean | 2 +- .../RS/Classical/Deligne/ZigzagNonzero.lean | 2 + .../RS/Classical/Deligne/ZigzagSandwich.lean | 8 +- .../RS/Classical/Deligne/ZigzagTransfer.lean | 2 +- .../Classical/Interfaces/DeligneBridge.lean | 4 +- .../Interfaces/EulerianIndependence.lean | 8 +- .../RS/Classical/Interfaces/KoszulAction.lean | 6 +- .../RS/Classical/Interfaces/OmegaPerm.lean | 4 +- .../Interfaces/OmegaTensorPower.lean | 36 +- .../Classical/Interfaces/SectorDischarge.lean | 30 +- .../Interfaces/SectorIntertwine.lean | 27 +- .../Classical/Interfaces/TotalDimension.lean | 8 +- .../RS/Classical/SchurTheory/BranchTrace.lean | 12 +- .../RS/Classical/SchurTheory/CentralElem.lean | 15 +- .../RS/Classical/SchurTheory/CharClass.lean | 4 +- .../RS/Classical/SchurTheory/CharDecomp.lean | 37 +- .../RS/Classical/SchurTheory/CharEquiv.lean | 5 +- .../Classical/SchurTheory/ColourWeight.lean | 14 +- .../Classical/SchurTheory/CommutantBound.lean | 30 +- .../Classical/SchurTheory/ContentCount.lean | 8 +- .../RS/Classical/SchurTheory/FixWeight.lean | 2 + .../RS/Classical/SchurTheory/HVal.lean | 14 +- .../RS/Classical/SchurTheory/JTChar.lean | 12 +- .../RS/Classical/SchurTheory/JTIntChar.lean | 8 +- .../Classical/SchurTheory/JTIrreducible.lean | 16 +- .../RS/Classical/SchurTheory/JTOrtho.lean | 16 +- .../RS/Classical/SchurTheory/JTPad.lean | 46 +- .../RS/Classical/SchurTheory/JTSimple.lean | 2 +- .../RS/Classical/SchurTheory/KillSimples.lean | 5 +- .../RS/Classical/SchurTheory/MixedCount.lean | 6 +- .../RS/Classical/SchurTheory/MixedFixed.lean | 22 +- .../Classical/SchurTheory/NativeAction.lean | 4 +- .../Classical/SchurTheory/NativeFaithful.lean | 24 +- .../RS/Classical/SchurTheory/NativeTable.lean | 43 +- .../RS/Classical/SchurTheory/OrbitBridge.lean | 6 +- .../SchurTheory/PackageAssembly.lean | 6 +- .../RS/Classical/SchurTheory/PairInner.lean | 28 +- .../RS/Classical/SchurTheory/PairOrbit.lean | 2 +- .../RS/Classical/SchurTheory/PairStab.lean | 6 +- .../RS/Classical/SchurTheory/PairingPos.lean | 48 +- .../RS/Classical/SchurTheory/PermModule.lean | 14 +- .../RS/Classical/SchurTheory/PowerSurj.lean | 2 +- .../Classical/SchurTheory/RegularTrace.lean | 6 +- .../Classical/SchurTheory/SameCycleQuot.lean | 6 +- .../RS/Classical/SchurTheory/ScalarTrace.lean | 5 +- .../RS/Classical/SchurTheory/SchurAction.lean | 13 +- .../Classical/SchurTheory/SignedTensor.lean | 2 +- .../RS/Classical/SchurTheory/SimpleEmbed.lean | 12 +- .../RS/Classical/SchurTheory/TensorTrace.lean | 6 +- .../Classical/SchurTheory/WordCommutant.lean | 20 +- .../RS/Classical/Super/ColourAction.lean | 6 +- .../RS/Classical/Super/ColourConj.lean | 12 +- .../RS/Classical/Super/ColourConjStep.lean | 7 +- .../RS/Classical/Super/ColourConjTop.lean | 1011 +++++------ .../RS/Classical/Super/ColourExtendSwap.lean | 17 +- .../RS/Classical/Super/ColourFormMatch.lean | 26 +- .../RS/Classical/Super/ColourMerge.lean | 696 ++++---- .../RS/Classical/Super/ColourMergeOdd.lean | 715 ++++---- .../RS/Classical/Super/ColourPairingSymm.lean | 6 +- .../RS/Classical/Super/ColourTotal.lean | 4 +- .../RS/Classical/Super/ColourWord.lean | 12 +- .../RS/Classical/Super/SuperVect.lean | 24 +- .../RS/Classical/Super/TotalSpace.lean | 4 +- .../RS/Classical/Super/WordSignPerm.lean | 14 +- .../RS/Classical/SymFun/AlternantExpand.lean | 6 +- .../RS/Classical/SymFun/AlternantPieri.lean | 6 +- .../RS/Classical/SymFun/AlternantStrict.lean | 8 +- .../RS/Classical/SymFun/Bialternant.lean | 8 +- .../RS/Classical/SymFun/BinomialDet.lean | 4 +- .../RS/Classical/SymFun/CoeffExtract.lean | 4 +- .../RS/Classical/SymFun/CoeffSplit.lean | 10 +- .../RS/Classical/SymFun/DeltaSeq.lean | 14 +- .../RS/Classical/SymFun/DimFormula.lean | 4 +- .../RS/Classical/SymFun/HInsert.lean | 4 +- .../RS/Classical/SymFun/HProdCoeff.lean | 2 +- .../RS/Classical/SymFun/HSubZ.lean | 4 +- .../RS/Classical/SymFun/JTDetExpand.lean | 8 +- .../RS/Classical/SymFun/LGVStrict.lean | 29 +- .../RS/Classical/SymFun/PieriChain.lean | 4 +- .../SymFun/RationalityFromRecurrence.lean | 12 +- .../SymFun/RecurrenceFromVanishing.lean | 12 +- .../RS/Classical/SymFun/SubsetEH.lean | 4 +- .../RS/Classical/SymFun/SuperPowerSums.lean | 2 +- .../RS/Classical/SymFun/TCount.lean | 10 +- .../RS/Classical/SymFun/TIdentity.lean | 4 +- .../RS/Classical/SymFun/ZetaExp.lean | 4 +- .../RS/Classical/SymFun/ZetaSeries.lean | 6 +- .../RS/Common/DiagramChain.lean | 4 +- .../RegtsSevenster/RS/Common/MathlibDeps.lean | 2 +- .../RegtsSevenster/RS/Common/PermCongr.lean | 13 +- .../RS/Common/PermTopSplit.lean | 14 +- .../RegtsSevenster/RS/Common/RowLenChain.lean | 4 +- .../RegtsSevenster/RS/Common/RowSpanRank.lean | 4 +- .../RS/Common/TraceSeparation.lean | 4 +- LeanPool/RegtsSevenster/RS/Definitions.lean | 150 +- .../RS/Novel/Coordinates/AdjSwapBmc.lean | 44 +- .../RS/Novel/Coordinates/BasisCoord.lean | 8 +- .../RS/Novel/Coordinates/BasisSplit.lean | 12 +- .../RS/Novel/Coordinates/BetaData.lean | 38 +- .../RS/Novel/Coordinates/BetaDiag.lean | 12 +- .../RS/Novel/Coordinates/BetaDiagForm.lean | 22 +- .../RS/Novel/Coordinates/BetaFlip.lean | 2 +- .../RS/Novel/Coordinates/BlockAlign.lean | 14 +- .../RS/Novel/Coordinates/BlockCanon.lean | 10 +- .../RS/Novel/Coordinates/BlockData.lean | 13 +- .../RS/Novel/Coordinates/BlockOddList.lean | 2 +- .../RS/Novel/Coordinates/BlockParity.lean | 14 +- .../RS/Novel/Coordinates/BlockRestrict.lean | 4 +- .../RS/Novel/Coordinates/BlockSigma.lean | 8 +- .../RS/Novel/Coordinates/BlockSort.lean | 4 +- .../RS/Novel/Coordinates/BraidWord.lean | 6 +- .../RS/Novel/Coordinates/CanonColour.lean | 4 +- .../RS/Novel/Coordinates/CanonPerm.lean | 66 +- .../RS/Novel/Coordinates/CapClosed.lean | 14 +- .../RS/Novel/Coordinates/CapExpansion.lean | 2 +- .../RS/Novel/Coordinates/CapFun.lean | 4 +- .../RS/Novel/Coordinates/CapPeel.lean | 515 +++--- .../RS/Novel/Coordinates/CapPeelSplit.lean | 8 +- .../RS/Novel/Coordinates/CapPerm.lean | 2 +- .../RS/Novel/Coordinates/CapSplit.lean | 4 +- .../RS/Novel/Coordinates/CapVal.lean | 2 +- .../RS/Novel/Coordinates/ChainLists.lean | 2 +- .../RS/Novel/Coordinates/CircleModel.lean | 6 +- .../RS/Novel/Coordinates/CircleScalar.lean | 14 +- .../RS/Novel/Coordinates/ConcatSign.lean | 5 +- .../RS/Novel/Coordinates/CoordInterface.lean | 2 +- .../RS/Novel/Coordinates/CoordOf.lean | 4 +- .../RS/Novel/Coordinates/CoreParity.lean | 125 +- .../RS/Novel/Coordinates/EdgeSign.lean | 12 +- .../RS/Novel/Coordinates/EvForm.lean | 4 +- .../RS/Novel/Coordinates/EvFormOdd.lean | 4 +- .../RS/Novel/Coordinates/EvLeaf.lean | 14 +- .../RS/Novel/Coordinates/FibreParam.lean | 74 +- .../RS/Novel/Coordinates/FlagEnum.lean | 14 +- .../RS/Novel/Coordinates/GlobalSlotList.lean | 13 +- .../RS/Novel/Coordinates/HRS.lean | 4 +- .../RS/Novel/Coordinates/IndexPerm.lean | 4 +- .../RS/Novel/Coordinates/ModelCoord.lean | 14 +- .../RS/Novel/Coordinates/ModelPermCoord.lean | 6 +- .../RS/Novel/Coordinates/ModelStarVec.lean | 6 +- .../RS/Novel/Coordinates/MultiStar.lean | 12 +- .../RS/Novel/Coordinates/NFDef.lean | 8 +- .../RS/Novel/Coordinates/NFValue.lean | 4 +- .../RS/Novel/Coordinates/OddFlip.lean | 8 +- .../RS/Novel/Coordinates/OddListMultiset.lean | 15 +- .../RS/Novel/Coordinates/OddPair.lean | 12 +- .../RS/Novel/Coordinates/OddSignProd.lean | 14 +- .../RS/Novel/Coordinates/OmegaCotensor.lean | 12 +- .../RS/Novel/Coordinates/OmegaStarVec.lean | 2 +- .../RS/Novel/Coordinates/OmegaTensor.lean | 18 +- .../RS/Novel/Coordinates/OmegaTransport.lean | 8 +- .../RS/Novel/Coordinates/OneBasis.lean | 12 +- .../RS/Novel/Coordinates/OrbitCard.lean | 24 +- .../RS/Novel/Coordinates/OutSignEdges.lean | 14 +- .../RS/Novel/Coordinates/PairEnum.lean | 12 +- .../RS/Novel/Coordinates/PairList.lean | 16 +- .../RS/Novel/Coordinates/ParameterModel.lean | 6 +- .../RS/Novel/Coordinates/PatternInv.lean | 2 +- .../RS/Novel/Coordinates/PowMerge.lean | 12 +- .../RS/Novel/Coordinates/RegroupSign.lean | 68 +- .../RS/Novel/Coordinates/ReindexBij.lean | 3 +- .../RS/Novel/Coordinates/ReindexHeart.lean | 12 +- .../RS/Novel/Coordinates/ReindexVanish.lean | 8 +- .../RS/Novel/Coordinates/RepFlag.lean | 14 +- .../RS/Novel/Coordinates/RiffleSign.lean | 39 +- .../RS/Novel/Coordinates/SignPair.lean | 2 +- .../RS/Novel/Coordinates/SkeinPowBraid.lean | 16 +- .../RS/Novel/Coordinates/SortFactor.lean | 2 +- .../RS/Novel/Coordinates/StarClassFactor.lean | 4 +- .../RS/Novel/Coordinates/StarPeel.lean | 320 ++-- .../RS/Novel/Coordinates/StarPerm.lean | 6 +- .../RS/Novel/Coordinates/StarRepeat.lean | 28 +- .../RS/Novel/Coordinates/StdTransport.lean | 16 +- .../RS/Novel/Coordinates/StrandTransport.lean | 18 +- .../RS/Novel/Coordinates/TauCount.lean | 2 +- .../RS/Novel/Coordinates/TauKey.lean | 2 +- .../RS/Novel/Coordinates/TopBraidMerge.lean | 8 +- .../RS/Novel/Coordinates/VertexSign.lean | 2 +- .../RS/Novel/Coordinates/VertexValue.lean | 2 +- .../RS/Novel/Envelope/AtomicIdempotents.lean | 17 +- .../RS/Novel/Envelope/BlockCycle.lean | 20 +- .../RS/Novel/Envelope/BlockFactor.lean | 22 +- .../RS/Novel/Envelope/BlockSplice.lean | 935 +++++----- .../RS/Novel/Envelope/BlockTower.lean | 8 +- .../RS/Novel/Envelope/CycleNormal.lean | 2 +- .../RS/Novel/Envelope/CycleTrace.lean | 8 +- .../RS/Novel/Envelope/EnvAbelian.lean | 12 +- .../RS/Novel/Envelope/EnvDeligne.lean | 4 +- .../RS/Novel/Envelope/EnvDelignePackage.lean | 4 +- .../RS/Novel/Envelope/EnvGenerator.lean | 20 +- .../RS/Novel/Envelope/EnvGrowth.lean | 4 +- .../RS/Novel/Envelope/EnvInstances.lean | 44 +- .../RS/Novel/Envelope/EnvSemisimple.lean | 21 +- .../RS/Novel/Envelope/Frobenius.lean | 16 +- .../RS/Novel/Envelope/KaroubiEmbBraided.lean | 4 +- .../RS/Novel/Envelope/KaroubiRigid.lean | 5 +- .../RS/Novel/Envelope/KaroubiSemisimple.lean | 4 +- .../RS/Novel/Envelope/MatBraided.lean | 10 +- .../RS/Novel/Envelope/MatEmbMonoidal.lean | 104 +- .../RS/Novel/Envelope/MatMonoidal.lean | 19 +- .../RS/Novel/Envelope/MatRigid.lean | 23 +- .../RS/Novel/Envelope/MatSemisimple.lean | 22 +- .../RS/Novel/Envelope/NilpotentMatTrace.lean | 20 +- .../RS/Novel/Envelope/PermTrace.lean | 4 +- .../RS/Novel/Envelope/ScalarPermTrace.lean | 2 +- .../RS/Novel/Envelope/ScalarTrace.lean | 2 +- .../RS/Novel/Envelope/SkeinDimBound.lean | 6 +- .../RS/Novel/Envelope/SkeinTower.lean | 6 +- .../RS/Novel/Envelope/SkeinTrace.lean | 4 +- .../RS/Novel/Envelope/SuperKill.lean | 4 +- .../RS/Novel/Envelope/SymPerm.lean | 4 +- .../RS/Novel/Envelope/SymPermCast.lean | 6 +- .../RS/Novel/Envelope/TensorPowSplit.lean | 18 +- .../RS/Novel/Extraction/CircleValue.lean | 2 +- .../RS/Novel/Extraction/Coordinates.lean | 30 +- .../RS/Novel/Extraction/CopairUnique.lean | 4 +- .../RS/Novel/Extraction/SnakeTransport.lean | 8 +- .../RS/Novel/Extraction/StdDuality.lean | 16 +- .../RS/Novel/Extraction/StdRigid.lean | 20 +- .../RS/Novel/Extraction/StdSuper.lean | 18 +- .../RS/Novel/Skein/AllInternalAgreement.lean | 12 +- .../Novel/Skein/AllInternalIndependence.lean | 2 +- .../RS/Novel/Skein/BraidedInstance.lean | 34 +- .../RS/Novel/Skein/BraidedNat.lean | 40 +- .../RS/Novel/Skein/BundleClose.lean | 44 +- .../RS/Novel/Skein/BundleMapClasses.lean | 16 +- .../RS/Novel/Skein/BundleTensor.lean | 48 +- .../RS/Novel/Skein/CanonExistence.lean | 8 +- .../RS/Novel/Skein/CanonTransport.lean | 2 +- .../RS/Novel/Skein/CanonicalFrame.lean | 6 +- .../RS/Novel/Skein/ChainAgreement.lean | 2 +- .../RS/Novel/Skein/ChordCount.lean | 6 +- .../RS/Novel/Skein/ChordLabels.lean | 2 +- .../RS/Novel/Skein/ChordParity.lean | 2 +- .../RS/Novel/Skein/ChordSwapParity.lean | 2 +- .../RS/Novel/Skein/CloseRotate.lean | 316 +--- .../RS/Novel/Skein/CloseRotateLeft.lean | 386 +--- .../RS/Novel/Skein/CloseUnion.lean | 2 +- .../RS/Novel/Skein/ClosedAgreement.lean | 8 +- .../RS/Novel/Skein/ClosedCutDispatch.lean | 4 +- .../RS/Novel/Skein/ClosedIdentify.lean | 21 +- .../RS/Novel/Skein/ClosedTopSum.lean | 5 +- .../RS/Novel/Skein/ColourGlue.lean | 107 +- .../RS/Novel/Skein/ColourPadding.lean | 4 +- .../RS/Novel/Skein/ColourRecursion.lean | 57 +- .../RS/Novel/Skein/ComposeAssoc.lean | 173 +- .../RS/Novel/Skein/ComposeNormal.lean | 34 +- .../RS/Novel/Skein/ComposeRelabel.lean | 20 +- .../RS/Novel/Skein/Composition.lean | 14 +- .../RS/Novel/Skein/ConverseAssembly.lean | 80 +- .../RS/Novel/Skein/ConverseFamily.lean | 37 +- .../RS/Novel/Skein/ConverseGram.lean | 2 +- .../RS/Novel/Skein/ConverseIdentity.lean | 4 +- .../RS/Novel/Skein/ConverseLift.lean | 25 +- .../RS/Novel/Skein/ConversePair.lean | 23 +- .../RS/Novel/Skein/ConverseTrip.lean | 55 +- .../RS/Novel/Skein/CrossingDelta.lean | 32 +- .../RS/Novel/Skein/CutMatching.lean | 130 +- .../RS/Novel/Skein/CutSubsetSum.lean | 8 +- .../RS/Novel/Skein/DirMatching.lean | 369 ++-- .../RS/Novel/Skein/DisjSubsetSplit.lean | 10 +- .../RS/Novel/Skein/DisjUnionFactor/A.lean | 30 +- .../RS/Novel/Skein/DisjUnionFactor/B.lean | 38 +- .../RS/Novel/Skein/DisjUnionFactor/C.lean | 10 +- .../RS/Novel/Skein/DisjUnionProduct.lean | 22 +- .../RS/Novel/Skein/EdgeColouring.lean | 16 +- .../RS/Novel/Skein/EdgeSum.lean | 12 +- .../RS/Novel/Skein/EdgeTerm.lean | 27 +- .../RS/Novel/Skein/Eulerian.lean | 8 +- .../RS/Novel/Skein/ExactPairingInstance.lean | 6 +- .../RS/Novel/Skein/FibreValue.lean | 4 +- .../RS/Novel/Skein/FlagGraph.lean | 6 +- .../RS/Novel/Skein/FlipSignForm.lean | 16 +- .../RS/Novel/Skein/FlipSignProduct.lean | 2 +- .../RS/Novel/Skein/FourLabelParity.lean | 4 +- .../RS/Novel/Skein/FragmentEquiv.lean | 40 +- .../RS/Novel/Skein/GlueAmbient.lean | 416 +++-- .../RS/Novel/Skein/GlueChord.lean | 41 +- .../RS/Novel/Skein/GlueChords.lean | 6 +- .../RS/Novel/Skein/GlueCircuitDelta.lean | 502 +++--- .../RS/Novel/Skein/GlueComm.lean | 1563 ++++++++++------- .../RS/Novel/Skein/GlueCrossDelta.lean | 20 +- .../RS/Novel/Skein/GlueFold.lean | 425 ++--- .../RS/Novel/Skein/GlueLedger.lean | 5 +- .../RS/Novel/Skein/GluePathMatch.lean | 184 +- .../RS/Novel/Skein/GlueRelTransport.lean | 34 +- .../RS/Novel/Skein/GlueSplitProof/A.lean | 13 +- .../RS/Novel/Skein/GlueSplitProof/C.lean | 46 +- .../RS/Novel/Skein/GlueSubsetBij.lean | 22 +- .../RS/Novel/Skein/GramRank.lean | 2 +- .../RS/Novel/Skein/HomCompose.lean | 10 +- .../RS/Novel/Skein/HomTensor.lean | 10 +- .../RS/Novel/Skein/HomTraceCyclic.lean | 2 +- .../RS/Novel/Skein/HomTraceNondegenerate.lean | 2 +- .../RS/Novel/Skein/IdentityLaw.lean | 1004 ++++++----- .../RS/Novel/Skein/IdentityLawRight.lean | 989 ++++++----- .../RS/Novel/Skein/InterfaceAlternate.lean | 27 +- .../RS/Novel/Skein/InterfaceContract.lean | 5 +- .../RS/Novel/Skein/InterfaceCut.lean | 43 +- .../RS/Novel/Skein/InterfaceOrderIso.lean | 4 +- .../RS/Novel/Skein/InterfaceShift.lean | 8 +- .../RS/Novel/Skein/LabelChords.lean | 2 +- .../RS/Novel/Skein/LedgerCast.lean | 4 +- .../RS/Novel/Skein/LedgerRecursion.lean | 31 +- .../RS/Novel/Skein/LedgerSets.lean | 2 +- .../RS/Novel/Skein/LedgerStage.lean | 7 +- .../RS/Novel/Skein/LedgerValue.lean | 2 +- .../RS/Novel/Skein/LoopExample.lean | 24 +- .../RS/Novel/Skein/LoopVerify.lean | 14 +- .../RS/Novel/Skein/MixedPartition.lean | 42 +- .../RS/Novel/Skein/MonoidalInstance.lean | 8 +- .../RS/Novel/Skein/MonoidalStruct.lean | 14 +- .../RS/Novel/Skein/Multiplicativity.lean | 8 +- .../RS/Novel/Skein/NonSeparatedStep.lean | 195 +- .../RS/Novel/Skein/OpenCircuits.lean | 15 +- .../RS/Novel/Skein/OrbitParities.lean | 6 +- .../RS/Novel/Skein/OrientExistence.lean | 22 +- .../RS/Novel/Skein/OrientationFlip.lean | 29 +- .../RS/Novel/Skein/PairCloseComm.lean | 8 +- .../RS/Novel/Skein/PairedAssembly.lean | 950 +++++----- .../RS/Novel/Skein/PairingConnectivity.lean | 2 +- .../RS/Novel/Skein/PairingSignature.lean | 2 +- .../RS/Novel/Skein/PairingSwap.lean | 2 +- .../RS/Novel/Skein/PairingValue.lean | 6 +- .../RS/Novel/Skein/PartialClose.lean | 20 +- .../RS/Novel/Skein/PartialCloseCompose.lean | 34 +- .../RS/Novel/Skein/PartialCloseTensor.lean | 34 +- .../RS/Novel/Skein/PathCanon.lean | 2 +- .../RS/Novel/Skein/PathLedger.lean | 30 +- .../RS/Novel/Skein/PathMatch.lean | 20 +- .../RS/Novel/Skein/PermCompose.lean | 10 +- .../RS/Novel/Skein/PermFragment.lean | 60 +- .../RS/Novel/Skein/PropThreeOpen.lean | 2 +- .../RS/Novel/Skein/RSTensor.lean | 142 +- .../RS/Novel/Skein/RelTransition.lean | 16 +- .../RS/Novel/Skein/RelValue.lean | 12 +- .../RS/Novel/Skein/RelabelChords.lean | 2 +- .../RS/Novel/Skein/RelabelInvariance.lean | 16 +- .../RS/Novel/Skein/RepairInvariance.lean | 8 +- .../RS/Novel/Skein/RigidInstance.lean | 1 + .../RS/Novel/Skein/RigidityClasses.lean | 6 +- .../RS/Novel/Skein/ScalarClass.lean | 2 +- .../RS/Novel/Skein/SeparatedParity.lean | 12 +- .../RS/Novel/Skein/SkeinCategory.lean | 2 +- .../RS/Novel/Skein/SkeinIdeal.lean | 2 +- .../RS/Novel/Skein/SkeinIdealLeft.lean | 2 +- .../RS/Novel/Skein/StarDecomposition.lean | 18 +- .../RS/Novel/Skein/StarEnum.lean | 28 +- .../RS/Novel/Skein/StarExplode.lean | 344 ++-- .../RS/Novel/Skein/StarPrep.lean | 18 +- .../RS/Novel/Skein/StateFlipSet.lean | 24 +- .../RS/Novel/Skein/StatusSet.lean | 2 +- .../RS/Novel/Skein/StepFrame.lean | 42 +- .../RS/Novel/Skein/StepLedger.lean | 2 +- .../RS/Novel/Skein/StepStatus.lean | 2 +- .../RS/Novel/Skein/StepStatusNonsep.lean | 2 +- .../RS/Novel/Skein/StrandBundle.lean | 20 +- .../RS/Novel/Skein/SumLexOrder.lean | 9 +- .../RS/Novel/Skein/SuperGram.lean | 84 +- .../RS/Novel/Skein/SuperSpace.lean | 22 +- .../RS/Novel/Skein/TensorAssoc.lean | 14 +- .../RS/Novel/Skein/TensorComm.lean | 2 +- .../RS/Novel/Skein/TensorIdeal.lean | 50 +- .../RS/Novel/Skein/TensorInterchange.lean | 409 +++-- .../RS/Novel/Skein/TensorUnit.lean | 18 +- .../RS/Novel/Skein/ThroughEdgeCut.lean | 2 +- .../RS/Novel/Skein/ThroughIndCFalse.lean | 2 +- .../RS/Novel/Skein/TraceCyclic.lean | 6 +- .../RS/Novel/Skein/TraceNondegenerate.lean | 2 +- .../RS/Novel/Skein/TransitionExists.lean | 21 +- .../RS/Novel/Skein/TransitionMove.lean | 4 +- .../RS/Novel/Skein/TransposeLedger.lean | 16 +- .../RS/Novel/Skein/TwoPathNonSep.lean | 80 +- .../RS/Novel/Skein/TwoPathStep.lean | 6 +- .../RS/Novel/Skein/VertexOddSign.lean | 26 +- .../RS/Novel/Skein/VertexSum.lean | 3 +- .../RegtsSevenster/RS/StatementConverse.lean | 20 +- .../RegtsSevenster/RS/TheoremConverse.lean | 2 +- .../RegtsSevenster/RS/TheoremPadding.lean | 4 +- 604 files changed, 12931 insertions(+), 11432 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean index fd10259b49..c0311de6c3 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean @@ -253,8 +253,8 @@ example : @HasScalarUnit = (fun (A : Type u) [CategoryTheory.Category.{v, u} 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] → + [_inst : CategoryTheory.Category.{v, u} A] → + [_inst_1 : CategoryTheory.Preadditive A] → [CategoryTheory.Linear ℂ A] → [CategoryTheory.MonoidalCategory A] → Prop) := rfl @@ -263,8 +263,8 @@ 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), +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 @@ -274,8 +274,8 @@ 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 : ℕ), +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 @@ -291,8 +291,8 @@ fun (A : Type u) [CategoryTheory.Category.{v, u} A] [CategoryTheory.MonoidalCate 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 + [_inst : CategoryTheory.Category.{v, u} A] → + [_inst_1 : CategoryTheory.MonoidalCategory A] → [CategoryTheory.RigidCategory A] → A → ℕ → ℕ → A) := rfl /- Upstream contract: @@ -317,9 +317,9 @@ fun (A : Type u) [CategoryTheory.Category.{v, u} A] [CategoryTheory.MonoidalCate 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] → + [_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 @@ -340,7 +340,7 @@ fun (A : Type u) [CategoryTheory.Category.{v, u} A] [CategoryTheory.MonoidalCate -/ 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 + [_inst : CategoryTheory.Category.{v, u} A] → [CategoryTheory.MonoidalCategory A] → Prop) := rfl /- Upstream contract: @@ -383,11 +383,11 @@ def RS.DeligneTheoremStatement.{u, v} : Prop := [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], +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 @@ -450,7 +450,7 @@ regts_sevenster_iff : DeligneTheoremStatement → example : DeligneTheoremStatement.{1, 1} → ∀ (f : ClosedFragment → ℂ), f emptyClosedFragment = 1 → - (∀ (W₁ W₂ : ClosedFragment) (a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → + (∀ (W₁ W₂ : ClosedFragment) (_a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → ((∃ R, EdgeRankBounded f R) ↔ IsMixedPartitionFunction f) := @regts_sevenster_iff @@ -466,7 +466,7 @@ regts_sevenster_quant_roundtrip : DeligneTheoremStatement → example : DeligneTheoremStatement.{1, 1} → ∀ (f : ClosedFragment → ℂ), f emptyClosedFragment = 1 → - (∀ (W₁ W₂ : ClosedFragment) (a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → + (∀ (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 @@ -583,7 +583,7 @@ regts_sevenster_prescribed : ∀ (f : ClosedFragment → ℂ), -/ example : ∀ (f : ClosedFragment → ℂ), f emptyClosedFragment = 1 → - (∀ (W₁ W₂ : ClosedFragment) (a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → + (∀ (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 @@ -620,7 +620,7 @@ regts_sevenster_prescribed_deligne_only : DeligneTheoremStatement → example : DeligneTheoremStatement.{1, 1} → ∀ (f : ClosedFragment → ℂ), f emptyClosedFragment = 1 → - (∀ (W₁ W₂ : ClosedFragment) (a : Fragment.Equiv W₁ W₂), f W₁ = f W₂) → + (∀ (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 @@ -708,7 +708,7 @@ example : @connectionRank = (fun f t => Module.finrank ℂ ↥(connectionMap f t 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 +example : @MixedFunctional.Represents = (fun {_k _ℓ} h f => ∀ (W : ClosedFragment), f W = mixedPartition h W : {k ℓ : ℕ} → MixedFunctional k ℓ → (ClosedFragment → ℂ) → Prop) := rfl /- Upstream contract: diff --git a/LeanPool/RegtsSevenster/RS/Classical/Algebra/FactorialTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/Algebra/FactorialTrace.lean index d5d1da07e4..75e1dddd88 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Algebra/FactorialTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Algebra/FactorialTrace.lean @@ -63,7 +63,7 @@ theorem trace_perm_pow by_cases hπ : π = 1 · subst π simp - · rw [if_neg hπ] + · 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Algebra/TraceCriterion.lean b/LeanPool/RegtsSevenster/RS/Classical/Algebra/TraceCriterion.lean index 1d576d92f3..2730bf22d6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Algebra/TraceCriterion.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Algebra/TraceCriterion.lean @@ -30,7 +30,7 @@ theorem isSemisimpleRing_of_trace {A : Type u} [Ring A] [Algebra ℂ A] (hnil : ∀ x : A, IsNilpotent x → τ x = 0) (hnondeg : ∀ a : A, (∀ b : A, τ (b * a) = 0) → a = 0) : IsSemisimpleRing A := by - haveI : IsArtinianRing A := isArtinian_of_tower ℂ inferInstance + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Growth.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Growth.lean index 01c87e4731..628f72c905 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Growth.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Growth.lean @@ -47,13 +47,13 @@ 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] [Abelian A] [HasFiniteBiproducts 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 hss hfd (tensorPow A Y N)).mono (hC N)⟩ + (lengthLE_finrank_end hab hss hfd (tensorPow A Y N)).mono (hC N)⟩ end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiLinear.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiLinear.lean index ad6386444f..dc4c03f9d2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiLinear.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiLinear.lean @@ -43,11 +43,11 @@ 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 - show (c • g.f) ≫ h.f = c • (g.f ≫ h.f) + 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 - show g.f ≫ (c • h.f) = c • (g.f ≫ h.f) + change g.f ≫ (c • h.f) = c • (g.f ≫ h.f) rw [Linear.comp_smul] /-- The underlying-morphism map is complex linear. -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiTrace.lean index a95aee8065..e3563a40fd 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiTrace.lean @@ -37,7 +37,7 @@ theorem karoubiEnd_isSemisimpleRing_of_trace {C : Type*} [Category C] (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 - haveI : FiniteDimensional ℂ (End P) := + have : FiniteDimensional ℂ (End P) := FiniteDimensional.of_injective (show End P →ₗ[ℂ] End P.X from karoubiHomLinearMap P P) (fun _ _ h => Karoubi.Hom.ext h) diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Length.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Length.lean index 28593f2b4c..4b7bccdfbe 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Length.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Length.lean @@ -54,7 +54,7 @@ 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 - haveI := Subobject.subsingleton_of_isZero hY + have := Subobject.subsingleton_of_isZero hY exact (hf (show (0 : Fin 2) < 1 by decide)).ne (Subsingleton.elim (f 0) (f 1)) @@ -101,7 +101,7 @@ private lemma pair_chains induction n with | zero => intro w _ - haveI : Subsingleton (Fin (0 + 1)) := + 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⟩, @@ -285,9 +285,9 @@ private lemma eq_of_parts [Category.{v} C] [Abelian C] ← h6, Category.assoc, h5, comp_zero] have hcz : cokernel.π (Subobject.ofLE P Q hPQ) = 0 := by rw [← hd, h7, comp_zero] - haveI : Epi (Subobject.ofLE P Q hPQ) := + have : Epi (Subobject.ofLE P Q hPQ) := Preadditive.epi_of_cokernel_zero hcz - haveI : IsIso (Subobject.ofLE P Q hPQ) := + 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])) diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LengthBound.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LengthBound.lean index 90de433d60..63f866ddd8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LengthBound.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LengthBound.lean @@ -78,7 +78,7 @@ theorem lengthLE_biproduct_of_simple [Category.{v} C] rw [IsZero.iff_id_eq_zero] exact biproduct.hom_ext _ _ fun j => j.elim0 | succ n ih => - haveI := hS 0 + 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) @@ -103,10 +103,10 @@ private lemma linearIndependent_of_orthogonal_idempotents [Category.{v} C] intro i by_cases h : i = j · subst h - rw [if_pos rfl, Linear.smul_comp, hidem] - · rw [if_neg h, Linear.smul_comp, horth i j h, smul_zero] + 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, if_pos (Finset.mem_univ j)] at h0 + 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, @@ -131,7 +131,7 @@ private lemma card_le_finrank_end [Category.{v} C] simp [hp, biproduct.ι_π_ne_assoc S hij] have hne : ∀ i, p i ≠ 0 := by intro i hzero - haveI := hS i + 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 @@ -140,7 +140,7 @@ private lemma card_le_finrank_end [Category.{v} C] exact hcalc.symm have hli := linearIndependent_of_orthogonal_idempotents p hne hidem horth - haveI : FiniteDimensional ℂ (Y ⟶ Y) := hfd + have : FiniteDimensional ℂ (Y ⟶ Y) := hfd have hcard := hli.fintype_card_le_finrank rw [Fintype.card_fin] at hcard exact hcard @@ -161,7 +161,7 @@ data that transports along that uniqueness. structure. -/ @[reducible] private def abelianOver [Category.{v} C] - [hpre : Preadditive C] [hab : Abelian C] : + [hpre : Preadditive C] (hab : Abelian C) : Abelian C := have hzero : @Preadditive.preadditiveHasZeroMorphisms C _ hab.toPreadditive = @@ -184,12 +184,12 @@ 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] - [Abelian C] [HasFiniteBiproducts 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 - letI : Abelian C := abelianOver + let : Abelian C := abelianOver hab exact ((lengthLE_biproduct_of_simple S hS).of_iso e.symm).mono (card_le_finrank_end hS e hfin) diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/PartialTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/PartialTrace.lean index 207c8a85af..d688c6599f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/PartialTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/PartialTrace.lean @@ -71,7 +71,7 @@ theorem ptr_whiskerRight_comp [RigidCategory C] {P X : C} (a : P ⟶ P) (f : P ⊗ X ⟶ P ⊗ X) : ptr ((a ▷ X) ≫ f) = a ≫ ptr f := by - show (ρ_ P).inv ≫ (P ◁ η_ X Xᘁ) ≫ (α_ P X Xᘁ).inv ≫ + 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 ≫ @@ -90,7 +90,7 @@ theorem ptr_comp_whiskerRight [RigidCategory C] {P X : C} (a : P ⟶ P) (f : P ⊗ X ⟶ P ⊗ X) : ptr (f ≫ (a ▷ X)) = ptr f ≫ a := by - show (ρ_ P).inv ≫ (P ◁ η_ X Xᘁ) ≫ (α_ P X Xᘁ).inv ≫ + 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 ≫ @@ -118,7 +118,7 @@ theorem ptr_whiskerLeft (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 - show (ρ_ (Q ⊗ R)).inv ≫ ((Q ⊗ R) ◁ η_ X Xᘁ) ≫ + 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 ≫ @@ -136,7 +136,7 @@ of the pairing. -/ theorem ptr_braiding [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] [RigidCategory C] (X : C) : ptr (β_ X X).hom = 𝟙 X := by - show (ρ_ X).inv ≫ (X ◁ η_ X Xᘁ) ≫ (α_ X X Xᘁ).inv ≫ + 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ᘁ`. @@ -210,7 +210,7 @@ private theorem catTrace_eq_ptl_trace pairTrace_eq (ExactPairing.tensor : ExactPairing (P ⊗ X) (Xᘁ ⊗ Pᘁ)) HasRightDual.exact f] - show η_ (P ⊗ X) (Xᘁ ⊗ Pᘁ) ≫ f ▷ (Xᘁ ⊗ Pᘁ) ≫ + change η_ (P ⊗ X) (Xᘁ ⊗ Pᘁ) ≫ f ▷ (Xᘁ ⊗ Pᘁ) ≫ (β_ (P ⊗ X) (Xᘁ ⊗ Pᘁ)).hom ≫ ε_ (P ⊗ X) (Xᘁ ⊗ Pᘁ) = catTrace (ptl f) calc diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Trace.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Trace.lean index 69e1d7eff8..5139c08794 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Trace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Trace.lean @@ -53,7 +53,7 @@ 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 - show η_ X Xᘁ ≫ (f + g) ▷ Xᘁ ≫ (β_ X Xᘁ).hom ≫ ε_ X Xᘁ = + 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] @@ -65,7 +65,7 @@ theorem catTrace_smul [MonoidalLinear ℂ C] [RigidCategory C] {X : C} (a : ℂ) (f : X ⟶ X) : catTrace (a • f) = a • catTrace f := by - show η_ X Xᘁ ≫ (a • f) ▷ Xᘁ ≫ (β_ X Xᘁ).hom ≫ ε_ X Xᘁ = + 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] @@ -77,7 +77,7 @@ theorem catTrace_comp_comm [RigidCategory C] {X Y : C} (f : X ⟶ Y) (g : Y ⟶ X) : catTrace (f ≫ g) = catTrace (g ≫ f) := by - show η_ X Xᘁ ≫ (f ≫ g) ▷ Xᘁ ≫ (β_ X Xᘁ).hom ≫ ε_ X Xᘁ = + 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] @@ -96,7 +96,7 @@ theorem catTrace_eq_loop [RigidCategory C] {X : C} (f : X ⟶ X) : catTrace f = η_ X Xᘁ ≫ (β_ X Xᘁ).hom ≫ Xᘁ ◁ f ≫ ε_ X Xᘁ := by - show η_ X Xᘁ ≫ f ▷ Xᘁ ≫ (β_ X Xᘁ).hom ≫ ε_ X Xᘁ = _ + change η_ X Xᘁ ≫ f ▷ Xᘁ ≫ (β_ X Xᘁ).hom ≫ ε_ X Xᘁ = _ rw [braiding_naturality_left_assoc] /-- The trace computed against a chosen exact pairing. -/ @@ -113,8 +113,8 @@ 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 - letI := p₁ - letI := p₂ + let := p₁ + let := p₂ obtain ⟨φ, hA, hB⟩ : ∃ φ : D₁ ⟶ D₂, η_ X D₁ ≫ X ◁ φ = η_ X D₂ ∧ φ ▷ X ≫ ε_ X D₂ = ε_ X D₁ := by @@ -123,7 +123,7 @@ theorem pairTrace_eq [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] @coevaluation_comp_rightAdjointMate C _ _ X X ⟨D₂⟩ ⟨D₁⟩ (𝟙 X) · simpa using @rightAdjointMate_comp_evaluation C _ _ X X ⟨D₂⟩ ⟨D₁⟩ (𝟙 X) - show η_ X D₂ ≫ f ▷ D₂ ≫ (β_ X D₂).hom ≫ ε_ X D₂ = + 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] @@ -283,7 +283,7 @@ theorem catTrace_tensorHom rw [End.mul_def, catTrace_eq_pairTrace (f ⊗ₘ g), pairTrace_eq (ExactPairing.tensor : ExactPairing (X ⊗ Y) (Yᘁ ⊗ Xᘁ)) HasRightDual.exact (f ⊗ₘ g)] - show η_ (X ⊗ Y) (Yᘁ ⊗ Xᘁ) ≫ (f ⊗ₘ g) ▷ (Yᘁ ⊗ Xᘁ) ≫ + 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, @@ -371,7 +371,7 @@ theorem catDim_unit [Category.{v} C] [MonoidalCategory C] [SymmetricCategory C] rw [← catTrace_id, catTrace_eq_pairTrace] exact pairTrace_eq _ _ _ rw [h, End.one_def] - show (ρ_ (𝟙_ C)).inv ≫ (𝟙 (𝟙_ C) ▷ 𝟙_ C) ≫ + change (ρ_ (𝟙_ C)).inv ≫ (𝟙 (𝟙_ C) ▷ 𝟙_ C) ≫ (β_ (𝟙_ C) (𝟙_ C)).hom ≫ (ρ_ (𝟙_ C)).hom = 𝟙 (𝟙_ C) rw [braiding_tensorUnit_left, MonoidalCategory.unitors_equal] monoidal diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean index e2d5dd43ad..ca5343df51 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean @@ -201,7 +201,7 @@ theorem actRight_ins (hv : actLeft A M.X ≫ v = (A ◁ v) ≫ (φ ▷ B) ≫ μ[B]) : actRight A M.X ≫ v = (v ▷ A) ≫ (B ◁ φ) ≫ μ[B] := by - show ((β_ M.X A).hom ≫ actLeft A M.X) ≫ v = _ + change ((β_ M.X A).hom ≫ actLeft A M.X) ≫ v = _ rw [Category.assoc, hv, ← BraidedCategory.braiding_naturality_left_assoc, ← BraidedCategory.braiding_naturality_right_assoc, @@ -425,7 +425,7 @@ theorem baseChangePair_linear_outer (B ◁ (modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M) ≫ (baseChangeDatum A B φ d).pair)) ≫ μ[B] := by - letI := modTensorModObj B (baseChangeMod φ M') + let := modTensorModObj B (baseChangeMod φ M') (baseChangeMod φ M) have hact : (B ◁ modTensorπ B (baseChangeMod φ M') (baseChangeMod φ M)) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeBiprod.lean index bd1c4e0128..d15620018a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeBiprod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeBiprod.lean @@ -65,7 +65,7 @@ lemma modBiprodInl_fst [Category.{v} D] [MonoidalCategory D] [Preadditive D] (M : Mod D A) (N : Mod D A) : modBiprodInl A M N ≫ modBiprodFst A M N = 𝟙 M := by apply Mod.hom_ext - show (biprod.inl : M.X ⟶ M.X ⊞ N.X) ≫ biprod.fst = 𝟙 M.X + 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 @@ -75,7 +75,7 @@ lemma modBiprodInr_snd [Category.{v} D] [MonoidalCategory D] [Preadditive D] (M : Mod D A) (N : Mod D A) : modBiprodInr A M N ≫ modBiprodSnd A M N = 𝟙 N := by apply Mod.hom_ext - show (biprod.inr : N.X ⟶ M.X ⊞ N.X) ≫ biprod.snd = 𝟙 N.X + 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 @@ -146,11 +146,10 @@ private lemma map_inl_snd (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, - MonoidalCategory.id_tensorHom] + simp only [Mod.id_hom', modBiprodInl_hom, modBiprodSnd_hom] repeat' erw [MonoidalCategory.id_tensorHom] erw [← MonoidalCategory.whiskerLeft_comp_assoc] - show B ◁ ((biprod.inl : M.X ⟶ M.X ⊞ N.X) ≫ biprod.snd) ≫ + 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, @@ -168,11 +167,10 @@ private lemma map_inr_fst (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, - MonoidalCategory.id_tensorHom] + simp only [Mod.id_hom', modBiprodInr_hom, modBiprodFst_hom] repeat' erw [MonoidalCategory.id_tensorHom] erw [← MonoidalCategory.whiskerLeft_comp_assoc] - show B ◁ ((biprod.inr : N.X ⟶ M.X ⊞ N.X) ≫ biprod.fst) ≫ + 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, @@ -214,7 +212,7 @@ theorem baseChangeBiprodFwd_bwd unfold baseChangeBiprodFwd baseChangeBiprodBwd erw [biprod.lift_desc] apply modTensor_hom_ext - show modTensorπ A (restrictRegular φ) (modBiprod A M N) ≫ + change modTensorπ A (restrictRegular φ) (modBiprod A M N) ≫ (modTensorMap A (𝟙 (restrictRegular φ)) (modBiprodFst A M N) ≫ modTensorMap A (𝟙 (restrictRegular φ)) @@ -229,8 +227,7 @@ theorem baseChangeBiprodFwd_bwd rw [modTensorπ_map_assoc, modTensorπ_map_assoc, modTensorπ_map, modTensorπ_map] simp only [Mod.id_hom', modBiprodFst_hom, modBiprodInl_hom, - modBiprodSnd_hom, modBiprodInr_hom, - MonoidalCategory.id_tensorHom] + modBiprodSnd_hom, modBiprodInr_hom] repeat' erw [MonoidalCategory.id_tensorHom] erw [← MonoidalCategory.whiskerLeft_comp_assoc, ← MonoidalCategory.whiskerLeft_comp_assoc, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean index ba8be0ec58..02bc74dfa6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean @@ -100,7 +100,6 @@ theorem projFormula_cover (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 _ ?_) @@ -165,10 +164,10 @@ theorem actRight_modTensor_restrictRegular ((baseChangeMod φ M).X ◁ φ) ≫ actRight B (baseChangeMod φ M).X := by have h := actLeft_restrict_baseChange A B φ M - show (β_ (baseChange φ M) A).hom ≫ + change (β_ (baseChange φ M) A).hom ≫ modTensorAct A (restrictRegular φ) M = _ rw [← h] - show (β_ (baseChange φ M) A).hom ≫ (φ ▷ baseChange φ M) ≫ + change (β_ (baseChange φ M) A).hom ≫ (φ ▷ baseChange φ M) ≫ baseChangeAct φ M = ((baseChange φ M) ◁ φ) ≫ (β_ (baseChange φ M) B).hom ≫ baseChangeAct φ M @@ -252,7 +251,7 @@ theorem actRight_toRegular 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 - show ((β_ Q.X A).hom ≫ actLeft A Q.X) ≫ g.hom = _ + change ((β_ Q.X A).hom ≫ actLeft A Q.X) ≫ g.hom = _ rw [Category.assoc, hlin, ← BraidedCategory.braiding_naturality_left_assoc, IsCommMonObj.mul_comm] @@ -406,7 +405,7 @@ theorem whiskerRight_modTensorπ_actRight_baseChange ((β_ (B ⊗ M.X) B).hom ≫ (α_ B B M.X).inv ≫ (μ[B] ▷ M.X)) ≫ modTensorπ A (restrictRegular φ) M := by - show (modTensorπ A (restrictRegular φ) M ▷ B) ≫ + change (modTensorπ A (restrictRegular φ) M ▷ B) ≫ (β_ (baseChange φ M) B).hom ≫ baseChangeAct φ M = _ refine Eq.trans (Category.assoc _ _ _).symm ?_ refine Eq.trans (eq_whisker diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeDatum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeDatum.lean index c5fc328478..6933f971e1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeDatum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeDatum.lean @@ -38,7 +38,7 @@ theorem baseChangePair_linear modTensorAct B (baseChangeMod φ M') (baseChangeMod φ M) ≫ baseChangePair A B φ d = (B ◁ baseChangePair A B φ d) ≫ μ[B] := by - show modTensorAct B (baseChangeMod φ M') + change modTensorAct B (baseChangeMod φ M') (baseChangeMod φ M) ≫ ((projFormula A B φ M' M).hom ≫ modTensorMap A (𝟙 (restrictRegular φ)) (d.pairMod) ≫ @@ -93,7 +93,7 @@ theorem baseChangeCopair_linear (baseChangeMod φ M') := by refine act_inv_of_act_hom B (projFormula A B φ M M') ?_ exact projFormula_linear A B φ M M' - show μ[B] ≫ + change μ[B] ≫ ((modTensorUnitRight A (restrictRegular φ)).inv ≫ modTensorMap A (𝟙 (restrictRegular φ)) (d.copairMod) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeLinear.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeLinear.lean index 2a4e02df95..ef52bf49de 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeLinear.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeLinear.lean @@ -562,7 +562,7 @@ theorem projFormula_linear Category.id_comp] exact modTensorDescAct_cast A B (restrictMod_baseChange_eq A B φ M) N _ _ _ _ hact - show modTensorAct B (baseChangeMod φ M) + change modTensorAct B (baseChangeMod φ M) (baseChangeMod φ N) ≫ (collapseHom A B φ (baseChangeMod φ M) N ≫ eqToHom (congrArg (fun P => modTensor A P N) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeMonoidal.lean index b96cbed3c8..0898b1c252 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeMonoidal.lean @@ -139,7 +139,7 @@ theorem projFormula_natural_right (Category.assoc _ _ _).symm) ?_ refine Eq.trans (Category.assoc _ _ _).symm ?_ refine Eq.trans (eq_whisker (hend _ _) _) ?_ - simp only [Category.assoc] + simp only [] conv_lhs => erw [Category.assoc]; arg 2; erw [Category.assoc] rfl @@ -315,7 +315,7 @@ theorem projFormula_assoc_leftCover refine Eq.trans (eq_whisker (whisker_exchange (projFormula A B φ M N).hom (modTensorπ A (restrictRegular φ) P)) _) ?_ - simp only [Category.assoc] + simp only [] erw [Category.assoc] rfl have hcore2 : ∀ {Z : D} diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTensor.lean index a4a8f7622b..9c9788de1a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTensor.lean @@ -45,7 +45,7 @@ lemma actRight_restrictMod [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 - show (β_ P.X A).hom ≫ (φ ▷ P.X) ≫ actLeft B P.X = + 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] @@ -155,7 +155,7 @@ noncomputable def collapseMid (collapseCover A B φ P N) (collapseCover_cond A B φ P N) /-- Defining equation of the half-descended collapse. -/ -@[reassoc (attr := simp)] +@[simp, reassoc] theorem whiskerLeft_collapseMid [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [HasCoequalizers D] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTransport.lean index 54f02dc1b6..8c22af3966 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTransport.lean @@ -194,7 +194,7 @@ theorem baseChangeMapMod_id (X : Mod D A) : baseChangeMapMod A B φ (𝟙 X) = 𝟙 (baseChangeMod φ X) := Mod.Hom.ext (by - show modTensorMap A (𝟙 (restrictRegular φ)) (𝟙 X) = _ + change modTensorMap A (𝟙 (restrictRegular φ)) (𝟙 X) = _ rw [modTensorMap_id, Mod.id_hom'] rfl) @@ -235,7 +235,7 @@ theorem modTensorMapMod_id (X W : Mod D B) : modTensorMapMod B (𝟙 X) (𝟙 W) = 𝟙 (modTensorMod B X W) := Mod.Hom.ext (by - show modTensorMap B (𝟙 X) (𝟙 W) = _ + change modTensorMap B (𝟙 X) (𝟙 W) = _ rw [modTensorMap_id, Mod.id_hom'] rfl) @@ -347,7 +347,7 @@ theorem baseChange_sandwichCon modTensorMapMod B (𝟙 (baseChangeMod φ M)) (baseChangeUnitIso A B φ).hom ≫ (modTensorUnitRightMod B (baseChangeMod φ M)).hom := by - show (modTensorAssocModIso B (baseChangeMod φ M) + change (modTensorAssocModIso B (baseChangeMod φ M) (baseChangeMod φ M') (baseChangeMod φ M)).hom ≫ modTensorMapMod B (𝟙 (baseChangeMod φ M)) ((baseChangeDatum A B φ d).pairMod) ≫ @@ -537,7 +537,7 @@ theorem baseChange_sandwichConR modTensorMapMod B (baseChangeUnitIso A B φ).hom (𝟙 (baseChangeMod φ M')) ≫ (modTensorUnitLeftMod B (baseChangeMod φ M')).hom := by - show (modTensorAssocModIso B (baseChangeMod φ M') + change (modTensorAssocModIso B (baseChangeMod φ M') (baseChangeMod φ M) (baseChangeMod φ M')).inv ≫ modTensorMapMod B ((baseChangeDatum A B φ d).pairMod) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensor.lean index 32b8881a81..d917a5526d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensor.lean @@ -203,7 +203,7 @@ lemma inclFilter_cons_pos 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, dif_pos h] + rw [inclFilter, dite_eq_left h] lemma inclFilter_cons_neg [Category.{v} D] [MonoidalCategory D] (B : ι → D) [∀ i, MonObj (B i)] @@ -215,7 +215,7 @@ lemma inclFilter_cons_neg 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, dif_neg h] + rw [inclFilter, dite_eq_right h] /-- Equal index lists give equal (conjugated) insertions. -/ lemma inclFilter_congr @@ -253,13 +253,13 @@ instance isMonHom_inclFilter ∀ l : List ι, IsMonHom (inclFilter B p l) | [] => inferInstanceAs (IsMonHom (𝟙 (𝟙_ D))) | i :: l => by - haveI := isMonHom_inclFilter B p l - haveI : IsMonHom (eqToHom (listTensor_cons B i l).symm) := + 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] - haveI : IsMonHom (eqToHom + 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])) := @@ -269,7 +269,7 @@ instance isMonHom_inclFilter listTensor B (i :: l.filter p)) infer_instance · rw [inclFilter_cons_neg B p l h] - haveI : IsMonHom (eqToHom + 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])])) := @@ -425,14 +425,14 @@ instance isMonHom_finTensorIncl [BraidedCategory D] {s t : Finset ι} (h : s ⊆ t) : IsMonHom (finTensorIncl B h) := by rw [finTensorIncl] - haveI : IsMonHom (eqToHom (show finTensor B s = + 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]) - haveI : IsMonHom (eqToHom + have : IsMonHom (eqToHom (show listTensor B (t.sort (· ≤ ·)) = finTensor B t from rfl)) := isMonHom_eqToHom B (l₁ := t.sort (· ≤ ·)) (l₂ := t.sort (· ≤ ·)) rfl rfl @@ -787,7 +787,7 @@ noncomputable def bigTensorMulCocone ι := { app := fun s => finTensorMul B s t ≫ bigTensorStage B (s ∪ t) naturality := fun {s s'} f => by - show (finTensorIncl B (leOfHom f) ▷ finTensor B t) ≫ + 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) @@ -819,7 +819,7 @@ lemma stage_bigTensorMulStage (s t : Finset ι) : (bigTensorStage B s ▷ finTensor B t) ≫ bigTensorMulStage B t = finTensorMul B s t ≫ bigTensorStage B (s ∪ t) := by - show (tensorRight (finTensor B t)).map + 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] @@ -853,7 +853,7 @@ noncomputable def bigTensorMulTotalCocone ι := { app := fun t => bigTensorMulStage B t naturality := fun {t t'} f => by - show (bigTensor B ◁ finTensorIncl B (leOfHom f)) ≫ + change (bigTensor B ◁ finTensorIncl B (leOfHom f)) ≫ bigTensorMulStage B t' = bigTensorMulStage B t ≫ 𝟙 (bigTensor B) rw [Category.comp_id] @@ -883,7 +883,7 @@ lemma stage_bigTensorMul_right (t : Finset ι) : (bigTensor B ◁ bigTensorStage B t) ≫ bigTensorMul B = bigTensorMulStage B t := by - show (tensorLeft (bigTensor B)).map + change (tensorLeft (bigTensor B)).map (colimit.ι (finTensorDiagram B) t) ≫ bigTensorMul B = bigTensorMulStage B t erw [bigTensorMul, ι_preservesColimitIso_hom_assoc] @@ -954,7 +954,7 @@ noncomputable def bigTensorMulLCocone ι := { app := fun t => finTensorMul B s t ≫ bigTensorStage B (s ∪ t) naturality := fun {t t'} f => by - show (finTensor B s ◁ finTensorIncl B (leOfHom f)) ≫ + 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) @@ -987,7 +987,7 @@ lemma stage_bigTensorMulStageL (s t : Finset ι) : (finTensor B s ◁ bigTensorStage B t) ≫ bigTensorMulStageL B s = finTensorMul B s t ≫ bigTensorStage B (s ∪ t) := by - show (tensorLeft (finTensor B s)).map + 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] @@ -1128,7 +1128,7 @@ instance isMonHom_bigTensorOf (i : ι) : IsMonHom (bigTensorOf B i) := by rw [bigTensorOf] - haveI : IsMonHom (eqToHom (finTensor_singleton B i).symm) := + 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 @@ -1166,7 +1166,7 @@ instance bigTensorCommMon [Category.{v} D] [MonoidalCategory D] [LinearOrder ι] [∀ X : D, PreservesColimitsOfShape (Finset ι) (tensorLeft X)] : IsCommMonObj (bigTensor B) where mul_comm := by - show (β_ (bigTensor B) (bigTensor B)).hom ≫ bigTensorMul B = + change (β_ (bigTensor B) (bigTensor B)).hom ≫ bigTensorMul B = bigTensorMul B apply bigTensor_pair_hom_ext B intro s t diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodPow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodPow.lean index 1e204bff1c..6bef4df0ed 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodPow.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodPow.lean @@ -281,7 +281,7 @@ theorem sum_mixedFrom_mixedInto (letterFrom X Y b ≫ letterInto X Y b)) = 𝟙 (tensorPow A (X ⊞ Y) (n + 1)) := by rw [← tensor_sum, Fintype.sum_bool] - show 𝟙 (tensorPow A (X ⊞ Y) n) ⊗ₘ + 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))) @@ -379,7 +379,7 @@ theorem wordPow_const_true [Category.{v} A] [MonoidalCategory A] induction n with | zero => rfl | succ n ih => - show wordPow X Y n (fun _ => true) ⊗ X = tensorPow A X n ⊗ X + 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 @@ -395,7 +395,7 @@ 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 - show wordPow X Y (p + q) + 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 @@ -533,7 +533,7 @@ theorem mixedInto_const_true | zero => exact (Category.id_comp _).symm | succ n ih => - show mixedInto X Y n (fun _ => true) ⊗ₘ + change mixedInto X Y n (fun _ => true) ⊗ₘ (biprod.inl : X ⟶ X ⊞ Y) = _ rw [ih] exact eqToHom_tensor_pull (wordPow_const_true X Y n) _ _ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodTransfer.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodTransfer.lean index 299b0b52d1..2f8a7f0512 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodTransfer.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodTransfer.lean @@ -98,6 +98,28 @@ theorem permMor_comp_permAlg 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 @@ -138,23 +160,7 @@ theorem SchurKilled.biprod 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 (X ⊞ Y) n (sortPerm w) ≫ - permMor (X ⊞ Y) n (sortPerm w)⁻¹ = 𝟙 _ := by - rw [show permMor (X ⊞ Y) n (sortPerm w) ≫ - permMor (X ⊞ Y) n (sortPerm w)⁻¹ = - permAlg (X ⊞ Y) n (MonoidAlgebra.single ((sortPerm w)⁻¹ * - sortPerm w) 1) from by - rw [show MonoidAlgebra.single ((sortPerm w)⁻¹ * - sortPerm w) (1 : ℂ) = - MonoidAlgebra.single (sortPerm w)⁻¹ 1 * - MonoidAlgebra.single (sortPerm w) 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 + 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) = diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BlockUnits.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BlockUnits.lean index d400305826..3e983b84da 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BlockUnits.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BlockUnits.lean @@ -93,13 +93,14 @@ theorem basisProj_ne_zero [AddCommGroup V] [Module ℂ V] {d : ℕ} 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] - [Fintype G] (e : MonoidAlgebra ℂ G) (hidem : e * e = e) + [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 ∧ @@ -109,13 +110,13 @@ theorem exists_simple_of_central_idem {G : Type*} [Group G] 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 - haveI := hT + 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 - show e * ((a • s : T) : MonoidAlgebra ℂ G) = + 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] } @@ -157,11 +158,12 @@ theorem nPsi_eq_one_of_forall_eq {G : Type*} [Group G] /-- 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] [Fintype G] - [DecidableEq G] +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 ∘ₗ @@ -208,10 +210,10 @@ theorem SchurPackage.exists_block_units (P : SchurPackage.{u}) -- A simple submodule inside the block. obtain ⟨S, hS, hSb⟩ := exists_simple_of_central_idem (P.e μ) hidem hcentral hne - haveI := hS - haveI := IsSimpleModule.nontrivial + have := hS + have := IsSimpleModule.nontrivial (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) S - haveI : Nontrivial (subCarrier 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 @@ -242,7 +244,7 @@ theorem SchurPackage.exists_block_units (P : SchurPackage.{u}) (nPsi S) : SymGroupAlgebra μ.card →ₐ[ℂ] ULift.{u} (Module.End ℂ (subCarrier S))) (P.e μ * x) = 0 := by - show (ULift.algEquiv (R := ℂ)).symm + change (ULift.algEquiv (R := ℂ)).symm (nPsi S (P.e μ * x)) = 0 rw [hx0, map_zero] exact P.block_faithful μ @@ -279,7 +281,7 @@ theorem SchurPackage.exists_block_units (P : SchurPackage.{u}) LinearMap.range (LinearMap.mulLeft ℂ (P.e μ)) := LinearMap.mem_range.mpr ⟨x, rfl⟩ refine ⟨⟨P.e μ * x, hmem⟩, ?_⟩ - show nPsi S (P.e μ * x) = T + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainAlgebra.lean index efceda047e..87d9b0316b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainAlgebra.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainAlgebra.lean @@ -194,7 +194,7 @@ noncomputable def chainMulCocone mu (smallNatEquiv.inverse.obj k) j ≫ chainColimitι B δ (smallNatEquiv.inverse.obj k + 1 + j) naturality := fun {k k'} f => by - show (chainMap B δ + change (chainMap B δ (leOfHom (smallNatEquiv.inverse.map f)) ▷ B j) ≫ (mu (smallNatEquiv.inverse.obj k') j ≫ chainColimitι B δ @@ -235,7 +235,7 @@ theorem ι_chainMulStage [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ B (i j : ℕ) : (chainColimitι B δ i ▷ B j) ≫ chainMulStage B δ mu hδl j = mu i j ≫ chainColimitι B δ (i + 1 + j) := by - show (tensorRight (B j)).map (colimit.ι (chainDiagram B δ) + 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) @@ -315,7 +315,7 @@ noncomputable def chainMulTotalCocone { app := fun k => chainMulStage B δ mu hδl (smallNatEquiv.inverse.obj k) naturality := fun {k k'} f => by - show (chainColimit B δ ◁ chainMap B δ + change (chainColimit B δ ◁ chainMap B δ (leOfHom (smallNatEquiv.inverse.map f))) ≫ chainMulStage B δ mu hδl (smallNatEquiv.inverse.obj k') = @@ -361,7 +361,7 @@ theorem whiskerLeft_ι_chainColimitMul (chainColimit B δ ◁ chainColimitι B δ j) ≫ chainColimitMul B δ mu hδl hδr = chainMulStage B δ mu hδl j := by - show (tensorLeft (chainColimit B δ)).map + change (tensorLeft (chainColimit B δ)).map (colimit.ι (chainDiagram B δ) (smallNatEquiv.functor.obj j)) ≫ chainColimitMul B δ mu hδl hδr = @@ -405,7 +405,7 @@ noncomputable def chainMulLCocone mu i (smallNatEquiv.inverse.obj k) ≫ chainColimitι B δ (i + 1 + smallNatEquiv.inverse.obj k) naturality := fun {k k'} f => by - show (B i ◁ chainMap B δ + change (B i ◁ chainMap B δ (leOfHom (smallNatEquiv.inverse.map f))) ≫ (mu i (smallNatEquiv.inverse.obj k') ≫ chainColimitι B δ @@ -445,7 +445,7 @@ theorem ι_chainMulStageL [Category.{v} E] (B : ℕ → E) (δ : ∀ n, B n ⟶ (i j : ℕ) : (B i ◁ chainColimitι B δ j) ≫ chainMulStageL B δ mu hδr i = mu i j ≫ chainColimitι B δ (i + 1 + j) := by - show (tensorLeft (B i)).map (colimit.ι (chainDiagram B δ) + 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean index 75f2af7c3d..bf3828c17d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean @@ -195,7 +195,7 @@ theorem chainBGrι_projZero chainBGrι A M M' d 0 ≫ chainBGrProjZero A M M' d = 𝟙 (chainBGrComponent A M M' d 0) := by rw [chainBGrι, chainBGrProjZero] - erw [Sigma.ι_desc] + erw [Sigma.ι_comp_desc] simp /-- **The graded unit does not vanish** when the balanced unit @@ -291,7 +291,7 @@ theorem whiskerLeft_ι_chainBGrMulStage chainBGrMulStage A M M' d a = chainBGrCompMul A M M' d a b ≫ chainBGrι A M M' d (a + b) := by - show (tensorLeft (chainBGrComponent A M M' d a)).map + 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 = @@ -365,7 +365,7 @@ theorem ι_whiskerRight_chainBGrMul (chainBGrι A M M' d a ▷ chainBGr A M M' d) ≫ chainBGrMul A M M' d = chainBGrMulStage A M M' d a := by - show (tensorRight (chainBGr A M M' d)).map + 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 = @@ -588,7 +588,7 @@ theorem chainBGrCompMul_comm eqToHom (congrArg (chainBGrComponent A M M' d) (Int.add_comm b a)) = chainBGrCompMul A M M' d a b := by - show (β_ (chainBGrComponent A M M' d a) + 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 ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean index 35802c61eb..b0800c0365 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean @@ -198,7 +198,7 @@ noncomputable def chainBdegZeroStageIso inv := chainStage2Cast A M M' (Nat.zero_add k).symm (Nat.zero_add k).symm hom_inv_id := by - show chainStage2Cast A M M' (Nat.zero_add k) + 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 = @@ -206,7 +206,7 @@ noncomputable def chainBdegZeroStageIso rw [chainStage2Cast_trans] exact chainStage2Cast_rfl A M M' _ _ inv_hom_id := by - show chainStage2Cast A M M' (Nat.zero_add k).symm + 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) = @@ -221,7 +221,6 @@ private theorem chainBdegZeroStage_compatibility [∀ 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 : ℕ) : chainDelta2 A M M' d (0 + k) (0 + k) ≫ @@ -278,7 +277,6 @@ private theorem chainBdegSuccStage_compatibility [∀ 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 : ℕ) : @@ -515,7 +513,7 @@ noncomputable def chainBdegInsPCocone chainBdegι A M M' d (p₀ + 1) q₀ (smallNatEquiv.inverse.obj k) naturality := fun {k k'} f => by - show (M'.X ◁ chainMap + 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))) ≫ @@ -570,7 +568,7 @@ theorem whiskerLeft_ι_chainBdegInsP chainBdegInsP A M M' d p₀ q₀ = chainBdegInsPStage A M M' p₀ q₀ k ≫ chainBdegι A M M' d (p₀ + 1) q₀ k := by - show (tensorLeft M'.X).map (colimit.ι (chainDiagram _ _) + 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₀) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBridge.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBridge.lean index 96453154dd..73177e544a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBridge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBridge.lean @@ -206,6 +206,30 @@ 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. -/ @@ -229,26 +253,11 @@ theorem projStage_mul 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 : 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 - show 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 + 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 - show modTensorπ A (modPowMod A M'.X k) + 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 : diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainDelta.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainDelta.lean index b8dc166fb3..179f9642ba 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainDelta.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainDelta.lean @@ -31,7 +31,7 @@ theorem powTailAct_zero_lambda [MonObj A] (X : D) [ModObj A X] : powTailAct A X 0 ≫ (λ_ X).hom = (A ◁ (λ_ X).hom) ≫ actLeft A X := by - show actAcross A (𝟙_ D) X ≫ (λ_ X).hom = _ + change actAcross A (𝟙_ D) X ≫ (λ_ X).hom = _ rw [actAcross] simp only [Category.assoc] rw [MonoidalCategory.leftUnitor_naturality] @@ -75,7 +75,7 @@ theorem symPowAct_symPowOne symPowAct A X 0 ≫ (symPowOne A X).hom = (A ◁ (symPowOne A X).hom) ≫ actLeft A X := by rw [symPowAct, symPowOne] - show ((A ◁ symPowσ A X 1) ≫ modPowAct A X 0 ≫ + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/Base.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/Base.lean index 8a6719ee02..145c6a3256 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/Base.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/Base.lean @@ -151,7 +151,7 @@ theorem symInsL_actRight rfl, show actLeft A (symPowMod A X (n + 1)).X = symPowAct A X (n + 1) from rfl] - show (X ◁ ((β_ (symPow A X (n + 1)) A).hom ≫ + 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) @@ -287,7 +287,7 @@ theorem chainInsP_cond from rfl, show actLeft A (symPowMod A M.X q).X = symPowAct A M.X q from rfl] - show M'.X ◁ (((β_ (symPow A M'.X (p + 1)) A).hom ≫ + 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 ≫ @@ -437,7 +437,7 @@ theorem chainInsQ_cond from rfl, show actLeft A (symPowMod A M.X q).X = symPowAct A M.X q from rfl] - show M.X ◁ (((β_ (symPow A M'.X (p + 1)) A).hom ≫ + 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 ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/FirstSlot.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/FirstSlot.lean index 24bec89dd3..56a514308c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/FirstSlot.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/FirstSlot.lean @@ -78,10 +78,7 @@ end InsSurgery section Ins2Laws -/-- **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 +private theorem chainInsP_mul_left [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] @@ -89,41 +86,22 @@ theorem chainInsP_mul [∀ 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 ?_ - show (M'.X ◁ + (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. + (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) @@ -303,6 +281,40 @@ theorem chainInsP_mul (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) @@ -477,6 +489,47 @@ theorem chainInsP_mul 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₀ = @@ -610,6 +663,43 @@ theorem chainInsP_mul (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₀) = @@ -623,7 +713,7 @@ theorem chainInsP_mul 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 - show (((α_ M'.X (symPow A M'.X (p + 1)) + 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)) ≫ @@ -688,30 +778,84 @@ theorem chainInsP_mul modTensorπ A (symPowMod A M'.X (p + 1 + r + 1)) (symPowMod A M.X (q + 1 + s))) (congrArg₂ (· ⊗ₘ ·) hfacL hfacR) - exact (l1.trans (l2.trans (l3.trans (l4.trans - (l5.trans l6))))).trans - (r1.trans (r2.trans (r3.trans (r4.trans (r5.trans - (r6.trans (r7.trans (r8.trans r9)))))))).symm + exact r9 -/-- **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 +/-- **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) - (d : ModDualityDatum A M M') (p q : ℕ) : + (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) = - 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. + 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 ≫ @@ -814,6 +958,30 @@ theorem chainInsP_delta2 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)) ≫ @@ -930,6 +1098,24 @@ theorem chainInsP_delta2 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 ≫ @@ -1047,10 +1233,34 @@ theorem chainInsP_delta2 (CategoryStruct.comp (ρ_ (M'.X ⊗ chainStage2 A M M' p q)).inv) (Category.assoc _ _ _) - exact (l1.trans (l2.trans (l3.trans (l4.trans (c1.trans - (c2.trans (c3.trans (c4.trans c5)))))))).trans - (b1.trans (b2.trans (b3.trans (b4.trans (b5.trans - (b6.trans b7)))))).symm + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/SecondSlot.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/SecondSlot.lean index 4d6dc02f74..4ee179d6f2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/SecondSlot.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/SecondSlot.lean @@ -161,11 +161,7 @@ end InsQSurgery section InsQ2Laws -/-- **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 +private theorem chainInsQ_mul_leftCover [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] @@ -173,41 +169,27 @@ theorem chainInsQ_mul [∀ 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 ?_ - show (M.X ◁ + (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. + (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) @@ -318,6 +300,46 @@ theorem chainInsQ_mul (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)) @@ -423,6 +445,43 @@ theorem chainInsQ_mul (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) @@ -567,6 +626,53 @@ theorem chainInsQ_mul 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 ≫ @@ -685,6 +791,57 @@ theorem chainInsQ_mul (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 ≫ @@ -795,6 +952,53 @@ theorem chainInsQ_mul (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₀) = @@ -817,7 +1021,7 @@ theorem chainInsQ_mul 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 - show ((((α_ M.X (symPow A M.X (q + 1)) + 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)) ≫ @@ -889,30 +1093,90 @@ theorem chainInsQ_mul modTensorπ A (symPowMod A M'.X (p + 1 + r)) (symPowMod A M.X (q + 1 + s + 1))) (congrArg₂ (· ⊗ₘ ·) hfacL hfacR) - exact (l1.trans (l2.trans (l3.trans (l4.trans - (l5.trans l6))))).trans - (r1.trans (r2.trans (r3.trans (r4.trans (r5.trans - (r6.trans (r7.trans (r8.trans r9)))))))).symm + exact r9 -/-- **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 +/-- **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) - (d : ModDualityDatum A M M') (p q : ℕ) : + (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) = - 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. + 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 ≫ @@ -1015,6 +1279,30 @@ theorem chainInsQ_delta2 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)) ≫ @@ -1131,6 +1419,24 @@ theorem chainInsQ_delta2 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 ≫ @@ -1248,10 +1554,34 @@ theorem chainInsQ_delta2 (CategoryStruct.comp (ρ_ (M.X ⊗ chainStage2 A M M' p q)).inv) (Category.assoc _ _ _) - exact (l1.trans (l2.trans (l3.trans (l4.trans (c1.trans - (c2.trans (c3.trans (c4.trans c5)))))))).trans - (b1.trans (b2.trans (b3.trans (b4.trans (b5.trans - (b6.trans b7)))))).symm + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMul.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMul.lean index 5cb1e3f9c1..0994083c40 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMul.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMul.lean @@ -47,7 +47,7 @@ theorem symMul_modTensor_cond rfl, show actLeft A (symPowMod A X n).X = symPowAct A X n from rfl] - show (((β_ (symPow A X (m + 1)) A).hom ≫ symPowAct A X m) ▷ + 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)) ≫ @@ -103,7 +103,7 @@ theorem symMulDesc_act conv_rhs => rw [← whiskerLeft_comp_assoc, modTensorπ_symMulDesc] have h := symMul_actLeft A X m n - show (α_ A (symPow A X (m + 1)) (symPow A X (n + 1))).inv ≫ + 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) @@ -210,7 +210,7 @@ theorem tensorHom_π_chainMul from rfl, show (symMulMod A M.X m n).hom = symMulDesc A M.X m n from rfl, ← Category.assoc] - show ((modTensorπ A (symPowMod A M'.X m) + 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)) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulHet.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulHet.lean index a3b649c7a4..1d43e46d99 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulHet.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulHet.lean @@ -94,7 +94,7 @@ noncomputable def chainMulHetCocone [Category.{v} E] [MonoidalCategory E] mu (smallNatEquiv.inverse.obj k) j ≫ chainColimitι F δF (smallNatEquiv.inverse.obj k + 1 + j) naturality := fun {k k'} f => by - show (chainMap B δB + change (chainMap B δB (leOfHom (smallNatEquiv.inverse.map f)) ▷ C j) ≫ (mu (smallNatEquiv.inverse.obj k') j ≫ chainColimitι F δF @@ -137,7 +137,7 @@ theorem ι_chainMulHetStage [Category.{v} E] [MonoidalCategory E] (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 - show (tensorRight (C j)).map (colimit.ι (chainDiagram B δB) + 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) @@ -183,7 +183,7 @@ noncomputable def chainMulHetTotalCocone [Category.{v} E] [MonoidalCategory E] chainMulHetStage B C F δB δF mu hδl (smallNatEquiv.inverse.obj k) naturality := fun {k k'} f => by - show (chainColimit B δB ◁ chainMap C δC + 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') = @@ -230,7 +230,7 @@ theorem whiskerLeft_ι_chainColimitMulHet [Category.{v} E] [MonoidalCategory E] (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 - show (tensorLeft (chainColimit B δB)).map + 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 = diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulLaws.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulLaws.lean index e5b2e56ed0..50395fce7e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulLaws.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulLaws.lean @@ -281,21 +281,25 @@ end SymCast section ChainComm -/-- **Commutativity of the chain multiplication**, up to the stage -transport of `n + 1 + m = m + 1 + n`. -/ -theorem chainMul_comm +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 : ℕ) : - (β_ (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 + (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) ≫ @@ -334,6 +338,24 @@ theorem chainMul_comm 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)) ≫ @@ -585,9 +607,7 @@ end TensorSurgery section ChainAssoc -/-- **Associativity of the chain multiplication**, up to the stage -transports onto the common arity `m + 1 + n + 1 + p`. -/ -theorem chainMul_assoc +private theorem chainMul_assoc_left [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] @@ -595,34 +615,31 @@ theorem chainMul_assoc [∀ 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 + ((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 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 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)) ⊗ₘ @@ -734,6 +751,127 @@ theorem chainMul_assoc (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)) ⊗ₘ @@ -891,67 +1029,8 @@ theorem chainMul_assoc chainStageCast A M M' h₂) := congrArg (CategoryStruct.comp _) (compTensorHom_whiskerLeft_split _ _ _ _) - 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 (l1.trans (l2.trans (l3.trans (l4.trans - (l5.trans l6))))).trans + 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainShift.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainShift.lean index 57f24fdf8e..e3e4475090 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainShift.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainShift.lean @@ -50,7 +50,7 @@ noncomputable def chainCocone ι := { app := fun k => legs (smallNatEquiv.inverse.obj k) naturality := fun {k k'} f => by - show chainMap B δ (leOfHom (smallNatEquiv.inverse.map f)) ≫ + change chainMap B δ (leOfHom (smallNatEquiv.inverse.map f)) ≫ legs (smallNatEquiv.inverse.obj k') = legs (smallNatEquiv.inverse.obj k) ≫ 𝟙 Z rw [Category.comp_id] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainStage2.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainStage2.lean index 1b6d040bc3..404ce9a81e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainStage2.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainStage2.lean @@ -200,7 +200,7 @@ theorem tensorHom_π_chainMul2 from rfl, show (symMulMod A M.X q s).hom = symMulDesc A M.X q s from rfl, ← Category.assoc] - show ((modTensorπ A (symPowMod A M'.X p) + 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)) ≫ @@ -237,24 +237,26 @@ end SymCast section Chain2Comm -/-- **Commutativity of the two-index chain multiplication**, up to -the slotwise stage transports. -/ -theorem chainMul2_comm +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 : ℕ) : - (β_ (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 + (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) ≫ @@ -293,6 +295,27 @@ theorem chainMul2_comm 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)) ≫ @@ -549,9 +572,7 @@ end TensorSurgery section Chain2Assoc -/-- **Associativity of the two-index chain multiplication**, up to -the slotwise stage transports onto the common arities. -/ -theorem chainMul2_assoc +private theorem chainMul2_assoc_left [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] @@ -559,40 +580,33 @@ theorem chainMul2_assoc [∀ 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 + ((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 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 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)) ⊗ₘ @@ -707,6 +721,134 @@ theorem chainMul2_assoc (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)) ⊗ₘ @@ -864,68 +1006,8 @@ theorem chainMul2_assoc chainStage2Cast A M M' hp₂ hq₂) := congrArg (CategoryStruct.comp _) (compTensorHom_whiskerLeft_split _ _ _ _) - 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 (l1.trans (l2.trans (l3.trans (l4.trans - (l5.trans l6))))).trans + 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CharSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CharSplit.lean index ddc8cc9e13..b1511482ea 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CharSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CharSplit.lean @@ -119,16 +119,16 @@ theorem jtChar_orthogonal {n : ℕ} (μ ν : Shape n) (hne : μ ≠ ν) : set ρν : Representation ℂ (Equiv.Perm (Fin n)) (subCarrier (jtSimple ν.val)) := (rhoS (jtSimple ν.val)).comp (permCastHom ν.prop.symm) with hρν - haveI : ρμ.IsIrreducible := + have : ρμ.IsIrreducible := isIrreducible_comp_permCastHom μ.prop.symm _ (rhoS_isIrreducible _ (jtSimple_simple μ.val)) - haveI : ρν.IsIrreducible := + 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 - haveI : Invertible ((Nat.card (Equiv.Perm (Fin n)) : ℂ)) := + 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), @@ -154,7 +154,7 @@ theorem jtChar_orthogonal {n : ℕ} (μ ν : Shape n) (hne : μ ≠ ν) : rw [← hchμ g, ← hchν g, hchar] exact hne (Shape.ext (diagramSchur_injective hds)).symm have horth := Representation.char_orthonormal ρμ ρν - rw [if_neg hnoiso] at horth + 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]] @@ -233,7 +233,7 @@ theorem cycleFun_expand {n : ℕ} (t : ℕ → ℂ) rw [Finset.sum_congr rfl (fun μ _ => show (a μ • Shape.e P μ).coeff g = a μ * (Shape.e P μ).coeff g from - MonoidAlgebra.smul_apply _ _ _)] at h + 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 @@ -300,7 +300,7 @@ theorem kronMult_exists_nat {n : ℕ} (lam μ ν : Shape n) : have hcard0 : ((Nat.card (Equiv.Perm (Fin n)) : ℂ)) ≠ 0 := by rw [Nat.card_eq_fintype_card] exact_mod_cast Fintype.card_ne_zero - haveI : Invertible ((Nat.card (Equiv.Perm (Fin n)) : ℂ)) := + 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)) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CommonAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CommonAlgebra.lean index b565db81d7..8fcdd3eec8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CommonAlgebra.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CommonAlgebra.lean @@ -39,9 +39,9 @@ theorem exists_common_algebra [SmallCategory C] [MonoidalCategory C] [Abelian C] ∃ (𝔸 : Ind C) (_ : MonObj 𝔸) (_ : IsCommMonObj 𝔸), MonObj.one (X := 𝔸) ≠ 0 ∧ ∀ i, ∃ φ : B i ⟶ 𝔸, IsMonHom φ := by - letI : DecidableRel (WellOrderingRel (α := ι)) := + let : DecidableRel (WellOrderingRel (α := ι)) := Classical.decRel _ - letI : LinearOrder ι := linearOrderOfSTO WellOrderingRel + let : LinearOrder ι := linearOrderOfSTO WellOrderingRel refine ⟨bigTensor B, bigTensorMon B, bigTensorCommMon B, bigTensorUnit_ne_zero_ind B hu hB, ?_⟩ intro i diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoprodPreserve.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoprodPreserve.lean index 142feb5035..ae572e5cd4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoprodPreserve.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoprodPreserve.lean @@ -72,7 +72,7 @@ noncomputable def liftToFinsetComparison (sigmaComparison G fun x : S => (Discrete.functor f).obj x) (isIso_sigmaComparison_stage G f S)) ?_ intro S T h - show ((Sigma.desc fun y : S => + 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⟩ : @@ -89,8 +89,8 @@ noncomputable def liftToFinsetComparison ∐ fun x : T => (Discrete.functor f).obj x)) apply Sigma.hom_ext intro x - erw [stage_ι_comp_assoc, ← G.map_comp, Sigma.ι_desc, - Sigma.ι_desc_assoc, stage_ι_comp] + 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 @@ -104,9 +104,9 @@ theorem preservesCoproduct_of_finite_and_filtered [PreservesColimitsOfShape (Finset (Discrete α)) G] (f : α → C) : PreservesColimit (Discrete.functor f) G := by - haveI : HasCoproduct f := + have : HasCoproduct f := HasColimit.mk (liftToFinsetColimitCocone (Discrete.functor f)) - haveI : HasCoproduct fun x => G.obj (f x) := + have : HasCoproduct fun x => G.obj (f x) := HasColimit.mk (liftToFinsetColimitCocone (Discrete.functor fun x => G.obj (f x))) have hD' : IsColimit ((Cocone.precompose @@ -121,7 +121,7 @@ theorem preservesCoproduct_of_finite_and_filtered { hom := sigmaComparison G f w := by intro S - show ((Sigma.desc fun s : 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) ⟶ @@ -133,10 +133,10 @@ theorem preservesCoproduct_of_finite_and_filtered ∐ f)) apply Sigma.hom_ext intro x - erw [Sigma.ι_desc_assoc, ι_comp_sigmaComparison, - stage_ι_comp_assoc, ← G.map_comp, Sigma.ι_desc] } - haveI : IsIso m := hD2.hom_isIso hD' m - haveI : IsIso (sigmaComparison G f) := by + 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 @@ -153,7 +153,7 @@ theorem preservesColimitsOfShape_discrete_of_finite_and_filtered PreservesColimitsOfShape (Discrete α) G := by constructor intro F - haveI := preservesCoproduct_of_finite_and_filtered G + have := preservesCoproduct_of_finite_and_filtered G (F.obj ∘ Discrete.mk) exact preservesColimit_of_iso_diagram G Discrete.natIsoFunctor.symm diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescent.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescent.lean index af4a07700f..01f0471a82 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescent.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescent.lean @@ -684,7 +684,7 @@ theorem countablyPresented_imageSubalgebra intro n rw [hτ] exact inferInstanceAs (IsIso (e n).inv) - haveI : IsIso τ := NatIso.isIso_of_isIso_app τ + have : IsIso τ := NatIso.isIso_of_isIso_app τ refine CountablyPresented.of_iso (HasColimit.isoOfNatIso (CategoryTheory.Functor.isoWhiskerLeft (AsSmall.down (C := ℕ)) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescentClose.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescentClose.lean index 180a89b71b..d55aad50d3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescentClose.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescentClose.lean @@ -269,7 +269,7 @@ theorem freeModHomEquiv_id (X : D) : freeModHomEquiv R X (freeMod R X) (𝟙 (freeMod R X)) = (λ_ X).inv ≫ η[R] ▷ X := by - show (λ_ X).inv ≫ (η[R] ▷ X) ≫ 𝟙 _ = _ + change (λ_ X).inv ≫ (η[R] ▷ X) ≫ 𝟙 _ = _ rw [Category.comp_id] /-- **An isomorphism of free modules from a round trip**: a pair of @@ -480,15 +480,15 @@ theorem locallyMixed_countablyPresented η[A] ≠ 0 ∧ CountablyPresented A ∧ Nonempty (freeMod A X ≅ freeMod A (L.mix p q)) := by obtain ⟨p, q, A, hmon, hcomm, hA, ⟨Φ⟩⟩ := h - letI := hmon - letI := hcomm + 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) - haveI := hjunit - haveI := mono_imageSubalgebraHom_whiskerRight A j X - haveI := mono_imageSubalgebraHom_whiskerRight A j (L.mix p q) + 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 @@ -523,12 +523,12 @@ theorem section_countablyPresented ∃ s : freeMod A W ⟶ freeMod A V, s ≫ freeModMap A g = 𝟙 (freeMod A W) := by obtain ⟨A, hmon, hcomm, hA, s, hs⟩ := h - letI := hmon - letI := hcomm + let := hmon + let := hcomm obtain ⟨j, hjunit, t, ht⟩ := exists_imageSubalgebra_single A hW (freeModHomEquiv A W (freeMod A V) s) - haveI := hjunit - haveI := mono_imageSubalgebraHom_whiskerRight A j W + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableNullstellensatz.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableNullstellensatz.lean index ef31b42ca1..884af72bfe 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableNullstellensatz.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableNullstellensatz.lean @@ -56,9 +56,9 @@ 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 - haveI := hm - letI := Ideal.Quotient.field m - haveI : Algebra.IsAlgebraic ℂ (R ⧸ m) := + 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 @@ -72,7 +72,7 @@ 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 - haveI : Algebra.IsAlgebraic ℂ K := algebraic_of_countable_dimension K h + 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]⟩ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoverFactor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoverFactor.lean index 8c3036fd67..dcebe5d68c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoverFactor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoverFactor.lean @@ -125,7 +125,7 @@ private theorem twistPow_cover_factor_zero (plainShuffle V R.X (0 + 1)).hom ≫ ((tensorPow D V (0 + 1)) ◁ modPowπ A R.X (0 + 1)) := by rw [twistPowModIso] - show modPowπ A ((tensorLeftMod A V R).X) 1 ≫ + 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))) = @@ -146,6 +146,71 @@ private theorem twistPow_cover_factor_zero 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. -/ @@ -164,7 +229,7 @@ theorem twistPow_cover_factor | 0 => twistPow_cover_factor_zero A V R | (k + 1) => by rw [twistPowModIso] - show modPowπ A ((tensorLeftMod A V R).X) (k + 1 + 0 + 1) ≫ + 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 ≫ @@ -203,64 +268,7 @@ theorem twistPow_cover_factor 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 : ((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)))))))) + 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) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CycleSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CycleSplit.lean index ed04e08bdd..30515785f0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CycleSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CycleSplit.lean @@ -51,7 +51,7 @@ theorem cycleType_permCongr' [Fintype α] [DecidableEq α] {β : Type*} [Fintype β] [DecidableEq β] (e : α ≃ β) (π : Equiv.Perm α) : (e.permCongr π).cycleType = π.cycleType := by - letI : DecidablePred (fun _ : β => True) := fun _ => .isTrue trivial + let : DecidablePred (fun _ : β => True) := fun _ => .isTrue trivial have h : e.permCongr π = π.extendDomain (e.trans (Equiv.subtypeUnivEquiv (fun _ : β => trivial)).symm) := by @@ -75,9 +75,10 @@ theorem cycleFunG_permCongr /-- 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 [DecidableEq α] +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 @@ -119,7 +120,7 @@ theorem permRestrict_of_invariant [Fintype α] [DecidableEq α] {π : Equiv.Perm α} {s : Finset α} (h : ∀ x, π x ∈ s ↔ x ∈ s) : permRestrict π s = π.subtypePerm h := by - rw [permRestrict, dif_pos h] + rw [permRestrict, dite_eq_left h] /-! ### Orbits as finite sets -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayCalculus.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayCalculus.lean index 501ff87e1b..7cc3849561 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayCalculus.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayCalculus.lean @@ -97,7 +97,7 @@ def dayCoyonedaCorepresentableBy [SmallCategory D] [MonoidalCategory D] (coyonedaEquiv (C := D × D) (X := ((a, b) : D × D)) (F := tensor D ⋙ F.functor)) homEquiv_comp {F F'} g f := by - show coyonedaEquiv (C := D × D) (X := ((a, b) : D × D)) + 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))) ≫ @@ -304,10 +304,10 @@ colimits. -/ noncomputable instance [SmallCategory D] [MonoidalCategory D] (F : MonoidalCategory.DayFunctor D (Type v)) : Limits.PreservesColimitsOfSize.{v, v} (tensorLeft F) := by - haveI : PreservesColimitsOfSize.{v, v} + have : PreservesColimitsOfSize.{v, v} ((tensor D).lan (H := Type v)) := ((tensor D).lanAdjunction (Type v)).leftAdjoint_preservesColimits - haveI : PreservesColimitsOfSize.{v, v} + have : PreservesColimitsOfSize.{v, v} (tensorLeft F ⋙ (equiv D (Type v)).functor) := preservesColimits_of_natIso (tensorLeftCompIso F).symm exact preservesColimits_of_reflects_of_preserves _ @@ -320,10 +320,10 @@ colimits. -/ noncomputable instance [SmallCategory D] [MonoidalCategory D] (F : MonoidalCategory.DayFunctor D (Type v)) : Limits.PreservesColimitsOfSize.{v, v} (tensorRight F) := by - haveI : PreservesColimitsOfSize.{v, v} + have : PreservesColimitsOfSize.{v, v} ((tensor D).lan (H := Type v)) := ((tensor D).lanAdjunction (Type v)).leftAdjoint_preservesColimits - haveI : PreservesColimitsOfSize.{v, v} + have : PreservesColimitsOfSize.{v, v} (tensorRight F ⋙ (equiv D (Type v)).functor) := preservesColimits_of_natIso (tensorRightCompIso F).symm exact preservesColimits_of_reflects_of_preserves _ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DeligneAssembly.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DeligneAssembly.lean index ebd28e5be5..63ed3858a4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DeligneAssembly.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DeligneAssembly.lean @@ -96,7 +96,7 @@ theorem scalarEnd_scalarUnitEquiv (h : HasScalarUnit D) (c : ℂ) (X : D) : scalarEnd (scalarUnitEquiv h) c X = c • 𝟙 X := by have hs : scalarHom (scalarUnitEquiv h) c = c • 𝟙 (𝟙_ D) := rfl - show (λ_ X).inv ≫ (scalarHom (scalarUnitEquiv h) c ▷ X) ≫ + 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, @@ -246,18 +246,18 @@ theorem exists_deligneFibreFunctor_small (hu : HasScalarUnit B) (X : B) (hgen : TensorGeneratedBy B X) (hgrow : ModerateLengthGrowth B) : Nonempty (DeligneFibreFunctor B) := by - letI := linearOfScalarUnit (doubledScalarUnit hu) - letI := monoidalLinearOfScalarUnitBraided (doubledScalarUnit hu) - letI := linearOfScalarUnit (indScalarUnit (doubledScalarUnit hu)) - letI := monoidalLinearOfScalarUnitBraided + 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 - letI := hmon - letI := hcomm - haveI hpm : ∀ Z : Ind (Doubled B), + let := hmon + let := hcomm + have hpm : ∀ Z : Ind (Doubled B), (tensorRight Z).PreservesMonomorphisms := fun _ => inferInstance - haveI hmono : Mono η[𝔹] := + have hmono : Mono η[𝔹] := mono_unit_ind (simple_unit_of_hasScalarUnit (hasScalarUnit_of_scalarUnit (doubledScalarUnit hu))) 𝔹 hne have hsec : ∀ T : CategoryTheory.ShortComplex (Doubled B), @@ -271,13 +271,13 @@ theorem exists_deligneFibreFunctor_small 𝟙 (freeMod 𝔹 ((T.map (indOf : Doubled B ⥤ Ind (Doubled B))).X₃)) := by intro T hT - haveI := (indOf_shortExact hT).epi_g + 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) - letI := indOf_additive (C := Doubled B) - letI := indOfFunctorLinear (doubledScalarUnit hu) - letI := evenEmbedLinear_scalarUnit hu + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DevissageBound.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DevissageBound.lean index e8761c1410..625c65848f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DevissageBound.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DevissageBound.lean @@ -45,8 +45,8 @@ theorem devissage_bound (hcard : lam.card ≠ 0) (hkill : SchurKilled P X lam) (st : DevissageState D L X) : st.units + st.lines ≤ 2 * lam.card := by - letI := st.monObj - letI := st.comm + 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) : diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledGrowth.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledGrowth.lean index 0282965129..0b21a513db 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledGrowth.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledGrowth.lean @@ -276,10 +276,10 @@ theorem IsSubquotientOf.sandwich [Category.{v} C] obtain ⟨s, r, hsr⟩ := hY obtain ⟨S, i, p, hi, hp⟩ := h obtain ⟨s', r', hsr'⟩ := hZ - haveI := hi - haveI := hp - haveI : IsSplitMono s' := IsSplitMono.mk' ⟨r', hsr'⟩ - haveI : IsSplitEpi r := IsSplitEpi.mk' ⟨s, hsr⟩ + 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 @@ -313,7 +313,7 @@ variable {C : Type u} /-- Retractions assemble over a finite biproduct. -/ theorem IsRetractOf.biproduct [Category.{v} C] [Preadditive C] - {J : Type} [Fintype J] {f g : J → C} + {J : Type} {f g : J → C} [HasBiproduct f] [HasBiproduct g] (h : ∀ t, IsRetractOf (f t) (g t)) : IsRetractOf (⨁ f) (⨁ g) := by diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSplit.lean index a7ecf85483..419d412583 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSplit.lean @@ -53,10 +53,10 @@ theorem exists_splitting_simple_algebra_doubled (indOf : Doubled A ⥤ Ind (Doubled A)) ∧ Nonempty (SuperPoint (gammaAlgebra (Ind (Doubled A)) doubledIndOddLine 𝔹)) := by - letI := linearOfScalarUnit (doubledScalarUnit hu) - letI := monoidalLinearOfScalarUnitBraided (doubledScalarUnit hu) - letI := linearOfScalarUnit (indScalarUnit (doubledScalarUnit hu)) - letI := monoidalLinearOfScalarUnitBraided + 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Doubling.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Doubling.lean index e5c41b27ae..0e46f16b25 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Doubling.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Doubling.lean @@ -1078,6 +1078,22 @@ 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 @@ -1086,50 +1102,39 @@ instance instMonoidalPreadditive [Category.{v} A] [MonoidalCategory A] [Preadditive A] [MonoidalPreadditive A] [HasBinaryBiproducts A] [HasZeroObject A] : MonoidalPreadditive (Doubled A) where - whiskerLeft_zero {X Y Z} := by - ext - · show 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 - · show 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 + whiskerLeft_zero := doubled_whiskerLeft_zero _ _ _ zero_whiskerRight {X Y Z} := by ext - · show biprod.map ((0 : Y.even ⟶ Z.even) ▷ X.even) + · 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 - · show biprod.map ((0 : Y.even ⟶ Z.even) ▷ X.odd) + · 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 - · show biprod.map (X.even ◁ (evenHom f + evenHom g)) + · 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 - · show biprod.map (X.even ◁ (oddHom f + oddHom g)) + · 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 - · show biprod.map ((evenHom f + evenHom g) ▷ X.even) + · 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 - · show biprod.map ((evenHom f + evenHom g) ▷ X.odd) + · 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) @@ -1144,21 +1149,21 @@ instance instMonoidalLinear [MonoidalLinear ℂ A] : MonoidalLinear ℂ (Doubled A) where whiskerLeft_smul X {Y Z} r f := by ext - · show biprod.map (X.even ◁ (r • evenHom f)) + · 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 - · show biprod.map (X.even ◁ (r • oddHom f)) + · 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 - · show biprod.map ((r • evenHom f) ▷ X.even) + · 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 - · show biprod.map ((r • evenHom f) ▷ X.odd) + · 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 @@ -1208,29 +1213,29 @@ instance instBraidedCategory ext · apply biprod.hom_ext' · apply tensorRight_ext - · simp [braidingEven, braidingOdd, assocEven, assocOdd] - · simp [braidingEven, braidingOdd, assocEven, assocOdd, + · simp [braidingEven, braidingOdd, assocEven] + · simp [braidingEven, braidingOdd, assocEven, Preadditive.neg_comp, Preadditive.comp_neg] · apply tensorRight_ext - · simp [braidingEven, braidingOdd, assocEven, assocOdd] - · simp [braidingEven, braidingOdd, assocEven, assocOdd, + · simp [braidingEven, braidingOdd, assocEven] + · simp [braidingEven, braidingOdd, assocEven, Preadditive.neg_comp, Preadditive.comp_neg] · apply biprod.hom_ext' <;> apply tensorRight_ext <;> - simp [braidingEven, braidingOdd, assocEven, assocOdd, + 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, assocOdd] - · simp [braidingEven, braidingOdd, assocEven, assocOdd, + · simp [braidingEven, braidingOdd, assocEven] + · simp [braidingEven, braidingOdd, assocEven, Preadditive.neg_comp, Preadditive.comp_neg] · apply tensorLeft_ext - · simp [braidingEven, braidingOdd, assocEven, assocOdd, + · simp [braidingEven, braidingOdd, assocEven, Preadditive.neg_comp, Preadditive.comp_neg] - · simp [braidingEven, braidingOdd, assocEven, assocOdd] + · simp [braidingEven, braidingOdd, assocEven] · apply biprod.hom_ext' <;> apply tensorLeft_ext <;> - simp [braidingEven, braidingOdd, assocEven, assocOdd, + simp [braidingEven, braidingOdd, assocOdd, Preadditive.neg_comp, Preadditive.comp_neg] /-- The doubling of a symmetric category is symmetric: the Koszul @@ -1241,13 +1246,13 @@ instance instSymmetricCategory [SymmetricCategory A] : SymmetricCategory (Doubled A) where symmetry X Y := by ext - · show biprod.map (β_ X.even Y.even).hom + · 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 - · show biprod.desc ((β_ X.even Y.odd).hom ≫ biprod.inr) + · 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) = @@ -1344,7 +1349,7 @@ theorem evenEmbedTensorIso_braided (evenEmbedTensorIso Y X).hom = (evenEmbedTensorIso X Y).hom ≫ evenEmbed.map (β_ X Y).hom := by ext - · show biprod.map (β_ X Y).hom (-(β_ (0 : A) (0 : A)).hom) ≫ + · change biprod.map (β_ X Y).hom (-(β_ (0 : A) (0 : A)).hom) ≫ biprod.fst = biprod.fst ≫ (β_ X Y).hom simp @@ -1399,7 +1404,7 @@ theorem braiding_oddUnit [Category.{v} A] [MonoidalCategory A] [Preadditive A] [SymmetricCategory A] : (β_ (oddUnit (A := A)) oddUnit).hom = -𝟙 (oddUnit ⊗ oddUnit) := by ext - · show biprod.map (β_ (0 : A) (0 : A)).hom + · change biprod.map (β_ (0 : A) (0 : A)).hom (-(β_ (𝟙_ A) (𝟙_ A)).hom) = -𝟙 ((0 : A) ⊗ (0 : A) ⊞ 𝟙_ A ⊗ 𝟙_ A) apply biprod.hom_ext @@ -1433,10 +1438,10 @@ instance instHasBinaryBiproducts has_binary_biproduct X Y := hasBinaryBiproduct_of_total (binaryBicone X Y) (by ext - · show biprod.fst ≫ biprod.inl + biprod.snd ≫ biprod.inr = + · change biprod.fst ≫ biprod.inl + biprod.snd ≫ biprod.inr = 𝟙 (X.even ⊞ Y.even) exact biprod.total - · show biprod.fst ≫ biprod.inl + biprod.snd ≫ biprod.inr = + · change biprod.fst ≫ biprod.inl + biprod.snd ≫ biprod.inr = 𝟙 (X.odd ⊞ Y.odd) exact biprod.total) @@ -1468,12 +1473,12 @@ def decomposition [Category.{v} A] [MonoidalCategory A] [Preadditive A] hom_inv_id := by rw [biprod.lift_desc] ext - · show 𝟙 X.even ≫ 𝟙 X.even + + · 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 - · show (0 : X.odd ⟶ (0 : A)) ≫ (0 : (0 : A) ⟶ X.odd) + + · change (0 : X.odd ⟶ (0 : A)) ≫ (0 : (0 : A) ⟶ X.odd) + ((λ_ X.odd).inv ≫ biprod.inr) ≫ biprod.desc 0 (λ_ X.odd).hom = 𝟙 X.odd @@ -1497,7 +1502,7 @@ def decomposition [Category.{v} A] [MonoidalCategory A] [Preadditive A] ext · exact (isZero_biprod (isZero_zeroTensor _) (isZero_tensorZero _)).eq_of_src _ _ - · show biprod.desc 0 (λ_ X.odd).hom ≫ + · change biprod.desc 0 (λ_ X.odd).hom ≫ (λ_ X.odd).inv ≫ biprod.inr = 𝟙 ((0 : A) ⊗ (0 : A) ⊞ 𝟙_ A ⊗ X.odd) apply biprod.hom_ext' diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/EvenEmbedMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/EvenEmbedMonoidal.lean index 2ce90420c8..8f09d2270c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/EvenEmbedMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/EvenEmbedMonoidal.lean @@ -220,7 +220,7 @@ def evenFunctorAdjEvenEmbed [Category.{v} A] [Preadditive A] [HasZeroObject A] : instance evenEmbedPreservesFiniteLimits [Category.{v} A] [Preadditive A] [HasZeroObject A] : PreservesFiniteLimits (evenEmbed (A := A)) := by - haveI : PreservesLimitsOfSize.{0, 0} (evenEmbed (A := A)) := + have : PreservesLimitsOfSize.{0, 0} (evenEmbed (A := A)) := (evenFunctorAdjEvenEmbed (A := A)).rightAdjoint_preservesLimits infer_instance @@ -228,7 +228,7 @@ instance evenEmbedPreservesFiniteLimits instance evenEmbedPreservesFiniteColimits [Category.{v} A] [Preadditive A] [HasZeroObject A] : PreservesFiniteColimits (evenEmbed (A := A)) := by - haveI : PreservesColimitsOfSize.{0, 0} (evenEmbed (A := A)) := + have : PreservesColimitsOfSize.{0, 0} (evenEmbed (A := A)) := (evenEmbedAdjEvenFunctor (A := A)).leftAdjoint_preservesColimits infer_instance diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreAdditive.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreAdditive.lean index d14f1c6f7e..041807d481 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreAdditive.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreAdditive.lean @@ -72,10 +72,10 @@ instance fibreFun_additive rw [fibreFun_map, fibreFun_map, fibreFun_map] refine SuperCommAlgebra.Mod.Hom.ext ?_ ?_ <;> refine LinearMap.ext fun m => ?_ - · show m ≫ (R ◁ (f + g)) = m ≫ (R ◁ f) + m ≫ (R ◁ g) + · change m ≫ (R ◁ (f + g)) = m ≫ (R ◁ f) + m ≫ (R ◁ g) rw [MonoidalPreadditive.whiskerLeft_add] exact Preadditive.comp_add _ _ _ _ _ _ - · show m ≫ (R ◁ (f + g)) = m ≫ (R ◁ f) + m ≫ (R ◁ g) + · change m ≫ (R ◁ (f + g)) = m ≫ (R ◁ f) + m ≫ (R ◁ g) rw [MonoidalPreadditive.whiskerLeft_add] exact Preadditive.comp_add _ _ _ _ _ _ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreExact.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreExact.lean index 8318436c4e..8c67d179c9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreExact.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreExact.lean @@ -211,7 +211,7 @@ theorem baseChangeRetraction_lin baseChangeRetractionHom R hS s hs = (R ◁ baseChangeRetractionHom R hS s hs) ≫ ((α_ R R S.X₁).inv ≫ (μ[R] ▷ S.X₁)) := by - haveI : Mono (R ◁ S.f) := (shortExact_map_tensorLeft R hS).mono_f + 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) @@ -282,7 +282,7 @@ theorem gammaModuleFunctor_map_add (gammaModuleFunctor L R).map h := by refine SuperCommAlgebra.Mod.Hom.ext ?_ ?_ <;> refine LinearMap.ext fun m => ?_ <;> - · show m ≫ Mod.Hom.hom f + m ≫ Mod.Hom.hom g = + · change m ≫ Mod.Hom.hom f + m ≫ Mod.Hom.hom g = m ≫ Mod.Hom.hom h erw [← Preadditive.comp_add, hfg] @@ -306,19 +306,19 @@ noncomputable def fibreFunSplitting r := (gammaModuleFunctor L R).map (baseChangeRetraction R hS s hs) s := (gammaModuleFunctor L R).map s f_r := by - show (gammaModuleFunctor L R).map (freeModMap R S.f) ≫ + 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 - show (gammaModuleFunctor L R).map s ≫ + 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 - show (gammaModuleFunctor L R).map + 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) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFaithful.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFaithful.lean index 69b54f4b66..0b203fa582 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFaithful.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFaithful.lean @@ -73,7 +73,7 @@ private theorem mixTotal Sum.elim (fun _ => 𝟙_ D) (fun _ => L.obj) k) i)).hom) ≫ e.inv.hom := by intro i - show (e.hom.hom ≫ + 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 => @@ -105,7 +105,7 @@ theorem whiskerLeft_eq_zero_of_fibre · have hz : (((λ_ (𝟙_ D)).inv ≫ (η[R] ▷ (𝟙_ D)) ≫ (mixSec L R e (Sum.inl j)).hom) ≫ (freeModMap R fm).hom) = 0 := by - show ((fibreFun L R).map fm).evenMap + change ((fibreFun L R).map fm).evenMap ((λ_ (𝟙_ D)).inv ≫ (η[R] ▷ (𝟙_ D)) ≫ (mixSec L R e (Sum.inl j)).hom) = 0 rw [h] @@ -116,7 +116,7 @@ theorem whiskerLeft_eq_zero_of_fibre · have hz : (((λ_ L.obj).inv ≫ (η[R] ▷ L.obj) ≫ (mixSec L R e (Sum.inr j)).hom) ≫ (freeModMap R fm).hom) = 0 := by - show ((fibreFun L R).map fm).oddMap + change ((fibreFun L R).map fm).oddMap ((λ_ L.obj).inv ≫ (η[R] ▷ L.obj) ≫ (mixSec L R e (Sum.inr j)).hom) = 0 rw [h] @@ -132,8 +132,8 @@ theorem eq_zero_of_whiskerLeft [∀ Z : D, (tensorRight Z).PreservesMonomorphisms] (hη : Mono η[R]) {V W : D} (fm : V ⟶ W) (h : R ◁ fm = 0) : fm = 0 := by - haveI := hη - haveI : Mono (η[R] ▷ W) := + 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 @@ -141,7 +141,7 @@ theorem eq_zero_of_whiskerLeft rw [← whisker_exchange, ← Category.assoc, ← leftUnitor_inv_naturality, Category.assoc] at h2 exact h2 - haveI : Mono ((λ_ W).inv ≫ (η[R] ▷ W)) := mono_comp _ _ + have : Mono ((λ_ W).inv ≫ (η[R] ▷ W)) := mono_comp _ _ exact (cancel_mono ((λ_ W).inv ≫ (η[R] ▷ W))).mp (h1.trans (Limits.zero_comp).symm) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFunctor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFunctor.lean index 548c2d0707..bda00f5205 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFunctor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFunctor.lean @@ -46,13 +46,13 @@ noncomputable def fibreFunctor map_id X := by refine SuperCommAlgebra.Mod.Hom.ext ?_ ?_ <;> refine LinearMap.ext fun m => ?_ <;> - · show m ≫ (freeModMap A (𝟙 X)).hom = 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 => ?_ <;> - · show m ≫ (freeModMap A (f ≫ g)).hom = + · 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreLinear.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreLinear.lean index fa285c02b7..bb20bac1df 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreLinear.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreLinear.lean @@ -36,10 +36,10 @@ instance fibreFun_linear rw [fibreFun_map, fibreFun_map] refine SuperCommAlgebra.Mod.Hom.ext ?_ ?_ <;> refine LinearMap.ext fun m => ?_ - · show m ≫ (R ◁ (c • f)) = c • (m ≫ (R ◁ f)) + · change m ≫ (R ◁ (c • f)) = c • (m ≫ (R ◁ f)) rw [MonoidalLinear.whiskerLeft_smul] exact CategoryTheory.Linear.comp_smul _ _ _ m c (R ◁ f) - · show m ≫ (R ◁ (c • f)) = c • (m ≫ (R ◁ f)) + · change m ≫ (R ◁ (c • f)) = c • (m ≫ (R ◁ f)) rw [MonoidalLinear.whiskerLeft_smul] exact CategoryTheory.Linear.comp_smul _ _ _ m c (R ◁ f) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMu.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMu.lean index d6f6201cd8..41adb5b506 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMu.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMu.lean @@ -148,8 +148,8 @@ theorem isIso_fibreMu (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 - haveI := h - haveI : IsIso (gammaFunMap L R (freeModTensorIso R V W).hom) := + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMuNat.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMuNat.lean index 4fbb08a9b4..27e3f7c0e5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMuNat.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMuNat.lean @@ -35,7 +35,7 @@ theorem freeModShuffle_naturality 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 - show ((R ◁ f) ⊗ₘ (R ◁ g)) ≫ + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverComplex.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverComplex.lean index 5a3971ab9b..789e368c3d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverComplex.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverComplex.lean @@ -124,10 +124,10 @@ theorem exists_superPoint_of_countable_family s ≫ freeModMap 𝔸 (g k) = 𝟙 (freeMod 𝔸 ((indOf : C ⥤ Ind C).obj (W k)))) ∧ Nonempty (SuperPoint (gammaAlgebra (Ind C) L 𝔸)) := by - letI := linearOfScalarUnit ψ - letI := monoidalLinearOfScalarUnitBraided ψ - letI := linearOfScalarUnit (indScalarUnit ψ) - letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + 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 @@ -140,8 +140,8 @@ theorem exists_superPoint_of_countable_family (fun k => section_countablyPresented (g k) (indCompactObj_indOf (V k)) (indCompactObj_indOf (W k)) hlen (hsplit k)) - letI := hmon - letI := hcomm + let := hmon + let := hcomm exact ⟨𝔸, hmon, hcomm, hne, hmixed, hsec, nonempty_superPoint_gammaAlgebra L 𝔸 hne hrk⟩ @@ -230,8 +230,8 @@ theorem exists_superVect_fibre {p q : ℕ} (e : freeMod 𝔸 X ≅ freeMod 𝔸 (L.mix p q)) : ∃ E : SuperVect, Module.finrank ℂ E.even = p ∧ Module.finrank ℂ E.odd = q := by - haveI := finiteDimensional_fibre_tensor_point_even L 𝔸 P e - haveI := finiteDimensional_fibre_tensor_point_odd L 𝔸 P e + 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) @@ -282,14 +282,14 @@ theorem exists_superPoint_fibre_of_countable_family (pointMod P)).odd = q ∧ ∃ E : SuperVect, Module.finrank ℂ E.even = p ∧ Module.finrank ℂ E.odd = q := by - letI := linearOfScalarUnit ψ - letI := monoidalLinearOfScalarUnitBraided ψ - letI := linearOfScalarUnit (indScalarUnit ψ) - letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + 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 - letI := hmon - letI := hcomm + 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, @@ -323,10 +323,10 @@ example Nonempty (freeMod 𝔸 ((indOf : C ⥤ Ind C).obj (Xf j)) ≅ freeMod 𝔸 (L.mix p q))) ∧ Nonempty (SuperPoint (gammaAlgebra (Ind C) L 𝔸)) := by - letI := linearOfScalarUnit ψ - letI := monoidalLinearOfScalarUnitBraided ψ - letI := linearOfScalarUnit (indScalarUnit ψ) - letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverSplitting.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverSplitting.lean index bb95550255..edbbf8d313 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverSplitting.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverSplitting.lean @@ -67,8 +67,8 @@ theorem indFibre_faithful [SmallCategory C] [MonoidalCategory C] [Abelian C] (hsp : SplitsOn L 𝔸 (indOf : C ⥤ Ind C)) [∀ Z : Ind C, (tensorRight Z).PreservesMonomorphisms] : ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸).Faithful := by - haveI : (indOf (C := C)).Additive := indOf_additive - haveI : ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸).Additive := + 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 @@ -92,7 +92,7 @@ theorem indOf_shortExact [SmallCategory C] [Abelian C] {S : CategoryTheory.ShortComplex C} (hS : S.ShortExact) : (S.map (indOf : C ⥤ Ind C)).ShortExact := by - haveI : (indOf (C := C)).Additive := indOf_additive + 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 @@ -130,8 +130,8 @@ theorem indFibre_preservesFiniteLimits s ≫ freeModMap 𝔸 ((S.map (indOf : C ⥤ Ind C)).g) = 𝟙 _) : Limits.PreservesFiniteLimits ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸) := by - haveI : (indOf (C := C)).Additive := indOf_additive - haveI : ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸).Additive := + have : (indOf (C := C)).Additive := indOf_additive + have : ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸).Additive := inferInstance exact preservesFiniteLimits_of_shortExact _ (indFibre_shortExact L 𝔸 hsec) @@ -150,8 +150,8 @@ theorem indFibre_preservesFiniteColimits s ≫ freeModMap 𝔸 ((S.map (indOf : C ⥤ Ind C)).g) = 𝟙 _) : Limits.PreservesFiniteColimits ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸) := by - haveI : (indOf (C := C)).Additive := indOf_additive - haveI : ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸).Additive := + have : (indOf (C := C)).Additive := indOf_additive + have : ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸).Additive := inferInstance exact preservesFiniteColimits_of_shortExact _ (indFibre_shortExact L 𝔸 hsec) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FiltNil.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FiltNil.lean index 41c9115ffe..50280f0b9c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FiltNil.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FiltNil.lean @@ -161,14 +161,14 @@ theorem comp_eq_zero_of_finChain refine comp_eq_zero_of_chain (fun k => if h : k ≤ N then F ⟨k, Nat.lt_succ_of_le h⟩ else ⊥) ?_ ?_ f ?_ - · rw [dif_pos (Nat.zero_le N)] + · rw [dite_eq_left (Nat.zero_le N)] exact htop - · rw [dif_pos (le_refl N)] + · 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 [dif_pos h2, dif_pos h1] + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FlatLimit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FlatLimit.lean index 1f7dce9924..43d6a30e57 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FlatLimit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FlatLimit.lean @@ -237,9 +237,10 @@ theorem DirectedColimitPresentation.exists_stage_family [IsDirectedOrder ι] {f : ∀ ⦃i j : ι⦄, i ≤ j → F i →+* F j} {R : Type*} [CommRing R] (P : DirectedColimitPresentation f R) - {κ : Type*} [Fintype κ] (x : κ → 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) @@ -255,10 +256,11 @@ theorem DirectedColimitPresentation.exists_stage_eq [CommRing R] (P : DirectedColimitPresentation f R) (hDS : DirectedSystem F fun _ _ h => f h) - {κ : Type*} [Fintype κ] {i : ι} {a b : κ → F i} + {κ : 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeMixRetract.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeMixRetract.lean index a543bd605a..fb47da2dcd 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeMixRetract.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeMixRetract.lean @@ -30,7 +30,7 @@ theorem freeModMap_biproduct_total [Category.{v} D] [MonoidalCategory D] [Preadditive D] [MonoidalPreadditive D] (A : D) [MonObj A] [HasFiniteBiproducts D] {ι : Type} [Fintype ι] - [DecidableEq ι] (f : ι → D) : + (f : ι → D) : ∑ i : ι, (freeModMap A (biproduct.π f i)).hom ≫ (freeModMap A (biproduct.ι f i)).hom = 𝟙 (freeMod A (⨁ f)).X := by diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModAdjoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModAdjoint.lean index c024821ac8..bd1f82bb7d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModAdjoint.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModAdjoint.lean @@ -214,7 +214,7 @@ noncomputable def freeModAdjunction homEquiv_naturality_left_symm := by intro X' X M u g apply Mod.Hom.ext - show A ◁ (u ≫ g) ≫ actLeft A M.X = + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffle.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffle.lean index 0bafde5c16..a5497ca45a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffle.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffle.lean @@ -43,11 +43,11 @@ 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 - show ((α_ B B (𝟙_ D)).inv ≫ μ[B] ▷ (𝟙_ D)) ≫ + change ((α_ B B (𝟙_ D)).inv ≫ μ[B] ▷ (𝟙_ D)) ≫ (ρ_ B).hom = (B ◁ (ρ_ B).hom) ≫ μ[B] exact freeModUnit_linear B) inv := Mod.Hom.mk' (ρ_ B).inv (by - show μ[B] ≫ (ρ_ B).inv = (B ◁ (ρ_ B).inv) ≫ + change μ[B] ≫ (ρ_ B).inv = (B ◁ (ρ_ B).inv) ≫ ((α_ B B (𝟙_ D)).inv ≫ μ[B] ▷ (𝟙_ D)) refine (cancel_mono (ρ_ B).hom).mp ?_ refine Eq.trans (Category.assoc _ _ _) ?_ @@ -145,13 +145,13 @@ noncomputable def freeModBiprodIso freeMod B (X ⊞ Y) ≅ modBiprod B (freeMod B X) (freeMod B Y) where hom := Mod.Hom.mk' (tensorBiprodIso B X Y).hom (by - show ((α_ B B (X ⊞ Y)).inv ≫ μ[B] ▷ (X ⊞ Y)) ≫ + 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 - show modBiprodAct B (freeMod B X) (freeMod B Y) ≫ + 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)) @@ -175,12 +175,12 @@ noncomputable def freeModMapIso inv := freeModMap B e.inv hom_inv_id := by apply Mod.Hom.ext - show (B ◁ e.hom) ≫ (B ◁ e.inv) = 𝟙 (B ⊗ V) + 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 - show (B ◁ e.inv) ≫ (B ◁ e.hom) = 𝟙 (B ⊗ W) + change (B ◁ e.inv) ≫ (B ◁ e.hom) = 𝟙 (B ⊗ W) rw [← MonoidalCategory.whiskerLeft_comp, e.inv_hom_id, MonoidalCategory.whiskerLeft_id] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModTensor.lean index b7b29cb3d9..5d7aaf672f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModTensor.lean @@ -331,13 +331,13 @@ noncomputable def freeModTensorIso modTensorMod R (freeMod R V) (freeMod R W) ≅ freeMod R (V ⊗ W) where hom := Mod.Hom.mk' (freeModTensorCarrier R V W).hom (by - show modTensorAct R (freeMod R V) (freeMod R W) ≫ + 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 - show ((α_ R R (V ⊗ W)).inv ≫ μ[R] ▷ (V ⊗ W)) ≫ + 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseStep.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseStep.lean index 134a03d4cb..9529fa64a7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseStep.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseStep.lean @@ -121,7 +121,7 @@ private theorem freeSlideWin_eq (V ◁ ((α_ A A V).inv ≫ (μ[A] ▷ V))) ≫ (((λ_ V).inv ≫ (η[A] ▷ V)) ▷ (A ⊗ V)) := by simp only [headSwap, Category.assoc, Iso.hom_inv_id_assoc] - show (((β_ A V).hom ≫ (((λ_ V).inv ≫ (η[A] ▷ V)) ▷ A)) ▷ + 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, @@ -189,7 +189,7 @@ place along. -/ theorem freeCollapse_freeInsert_succ [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (A : D) [MonObj A] - [IsCommMonObj A] (V : D) (k : ℕ) : + (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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePow.lean index debea194a8..d7d046e682 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePow.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePow.lean @@ -115,7 +115,7 @@ theorem insertTop_muFold | n + 1, k + 1 => by have h : (insertTop A n k ▷ A) ≫ muFold A (n + 2) = muFold A (n + 2) := by - show (insertTop A n k ▷ A) ≫ ((muFold A (n + 1) ▷ A) ≫ μ[A]) + 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] @@ -133,7 +133,7 @@ theorem muFold_permMor permMor A n σ ≫ muFold A n = muFold A n := by induction n with | zero => - show 𝟙 _ ≫ _ = _ + change 𝟙 _ ≫ _ = _ exact Category.id_comp _ | succ n ih => rw [permMor_succ] @@ -141,7 +141,7 @@ theorem muFold_permMor refine (congrArg (fun z => (permMor A n (restPerm σ) ▷ A) ≫ z) (insertTop_muFold A n _)).trans ?_ - show (permMor A n (restPerm σ) ▷ A) ≫ + change (permMor A n (restPerm σ) ▷ A) ≫ ((muFold A n ▷ A) ≫ μ[A]) = (muFold A n ▷ A) ≫ μ[A] rw [← Category.assoc, ← comp_whiskerRight, ih] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowDesc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowDesc.lean index f6f5b36a3a..cc04643c9e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowDesc.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowDesc.lean @@ -124,7 +124,7 @@ private theorem freeCollapse_concat_collect freeModShuffle A (tensorPow D V a) (tensorPow D V b) ≫ (A ◁ (tensorPowConcat V a b).hom) | 0 => by - show (ρ_ (tensorPow D (A ⊗ V) a)).hom ≫ freeCollapse A V a = + 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) ≫ @@ -154,7 +154,7 @@ private theorem freeCollapse_concat_collect freeModShuffle A (tensorPow D V b) V) := by rw [← MonoidalCategory.id_tensorHom, tensorHom_comp_tensorHom, Category.comp_id] - show ((α_ (tensorPow D (A ⊗ V) a) + 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)) ≫ @@ -179,7 +179,7 @@ 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] [IsCommMonObj A] + (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) ≫ @@ -237,7 +237,7 @@ private theorem freeWindow_legM 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] - show (((β_ (A ⊗ V) A).hom ≫ (α_ A A V).inv ≫ (μ[A] ▷ V)) ▷ + 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] @@ -255,7 +255,7 @@ private theorem freeWindow_legN 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] - show ((α_ (A ⊗ V) A (A ⊗ V)).hom ≫ + 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, @@ -312,7 +312,7 @@ private theorem freeLeg_window ((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 - show (tensorPow D (A ⊗ V) a ◁ L) ≫ + 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)) ≫ @@ -351,7 +351,7 @@ theorem freeCollapse_leg 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, Category.id_comp, modPowLegM, modPowLegN, + simp only [powCast_rfl, modPowLegM, modPowLegN, Category.assoc] erw [Category.id_comp] change ((tensorPow D (A ⊗ V) a ◁ winLegM A (freeMod A V).X) ▷ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowInsert.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowInsert.lean index 0e0d981859..04d460a43b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowInsert.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowInsert.lean @@ -67,12 +67,12 @@ section Fold /-- Folding a word of units gives the unit. -/ theorem unitWord_muFold [Category.{v} D] [MonoidalCategory D] [BraidedCategory D] - (A : D) [MonObj A] [IsCommMonObj A] (n : ℕ) : + (A : D) [MonObj A] (n : ℕ) : unitWord A n ≫ muFold A n = η[A] := by induction n with | zero => exact Category.id_comp _ | succ n ih => - show ((ρ_ (𝟙_ D)).inv ≫ (unitWord A n ⊗ₘ η[A])) ≫ + 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, @@ -121,12 +121,12 @@ theorem unitPow_plainShuffle (unitWord A n ▷ tensorPow D V n) := by induction n with | zero => - show 𝟙 (𝟙_ D) ≫ (λ_ (𝟙_ D)).inv = + change 𝟙 (𝟙_ D) ≫ (λ_ (𝟙_ D)).inv = (λ_ (𝟙_ D)).inv ≫ (𝟙 (𝟙_ D) ▷ 𝟙_ D) rw [Category.id_comp, MonoidalCategory.id_whiskerRight, Category.comp_id] | succ n ih => - show (freeUnitPow A V n ⊗ₘ ((λ_ V).inv ≫ (η[A] ▷ V))) ≫ + 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 ≫ @@ -208,7 +208,7 @@ theorem freeInsert_freeCollapse MonoidalCategory.tensorHom_id, ← MonoidalCategory.comp_whiskerRight, hA] rw [hcol] - show ((α_ A (tensorPow D V n) V).inv ≫ + 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))) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSlide.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSlide.lean index 5a46675472..28e07a6e30 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSlide.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSlide.lean @@ -39,8 +39,8 @@ theorem freeSplit_actRight [MonObj A] (V : D) : letI := freeModObj A V freeSplit A V ≫ actRight A (A ⊗ V) = 𝟙 (A ⊗ V) := by - letI := freeModObj A V - show freeSplit A V ≫ (β_ (A ⊗ V) A).hom ≫ + 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, @@ -68,7 +68,7 @@ theorem freeSplit_winLegM letI := freeModObj A V (freeSplit A V ▷ (A ⊗ V)) ≫ winLegM A (A ⊗ V) = 𝟙 ((A ⊗ V) ⊗ (A ⊗ V)) := by - letI := freeModObj A V + let := freeModObj A V rw [winLegM, ← MonoidalCategory.comp_whiskerRight, freeSplit_actRight, MonoidalCategory.id_whiskerRight] @@ -88,7 +88,7 @@ theorem freeSlideWin_modPowπ modPowπ A (A ⊗ V) n = modPowGlue (A ⊗ V) a b ≫ powCast (A ⊗ V) hab ≫ modPowπ A (A ⊗ V) n := by - letI := freeModObj A V + 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))) ▷ @@ -128,7 +128,7 @@ theorem freeSlideTop_modPowπ letI := freeModObj A V freeSlideTop A V k ≫ modPowπ A (A ⊗ V) (k + 2) = modPowπ A (A ⊗ V) (k + 2) := by - letI := freeModObj A V + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSummand.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSummand.lean index a9ef72158e..8b2294952e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSummand.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSummand.lean @@ -51,7 +51,7 @@ theorem exists_split_of_linear_idem {n : ℕ} b.equivFun.symm.toLinearMap, b.equivFun.toLinearMap ∘ₗ f.rangeRestrict, ?_, ?_⟩ · refine LinearMap.ext fun x => ?_ - show ((b.equivFun.symm (b.equivFun (f.rangeRestrict x)) : + change ((b.equivFun.symm (b.equivFun (f.rangeRestrict x)) : LinearMap.range f) : Fin n → ℂ) = f x rw [LinearEquiv.symm_apply_apply] rfl @@ -59,7 +59,7 @@ theorem exists_split_of_linear_idem {n : ℕ} have h1 : f.rangeRestrict ((b.equivFun.symm w : LinearMap.range f) : Fin n → ℂ) = b.equivFun.symm w := Subtype.ext (hU _) - show b.equivFun (f.rangeRestrict + change b.equivFun (f.rangeRestrict ((b.equivFun.symm w : LinearMap.range f) : Fin n → ℂ)) = w rw [h1, LinearEquiv.apply_symm_apply] @@ -86,12 +86,15 @@ 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} [Fintype J] [Fintype K] - [Fintype M] {f : J → D} {g : K → D} {h : M → 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 @@ -107,27 +110,34 @@ theorem components_comp [Category.{v} D] [Preadditive D] [HasFiniteBiproducts D] /-- Two maps of biproducts with the same matrix agree. -/ theorem hom_ext_components [Category.{v} D] [Preadditive D] [HasFiniteBiproducts D] - {J K : Type} [Fintype J] [Fintype K] + {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} [Fintype J] [DecidableEq J] + {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} [Fintype J] [DecidableEq J] + {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 @@ -199,7 +209,7 @@ theorem OddLine.eq_zero_of_whiskerRight {X Y : D} (f : X ⟶ Y) (h : f ▷ L.obj = 0) : f = 0 := by refine L.whiskerRight_injective ?_ - show f ▷ L.obj = (0 : X ⟶ Y) ▷ L.obj + change f ▷ L.obj = (0 : X ⟶ Y) ▷ L.obj rw [h, MonoidalPreadditive.zero_whiskerRight] end Line @@ -271,15 +281,17 @@ target. -/ theorem unitBij_biproduct_right [Category.{v} D] [MonoidalCategory D] [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] (R : D) [MonObj R] - {J : Type} [Fintype J] - [DecidableEq J] (V : D) (g : J → D) + {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 ?_ - show (x ≫ biproduct.π g k) ≫ algUnitHom R (g k) = + 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'] @@ -288,7 +300,7 @@ theorem unitBij_biproduct_right have hf' : ∀ k : J, f k ≫ algUnitHom R (g k) = y ≫ (R ◁ biproduct.π g k) := hf refine ⟨∑ k : J, f k ≫ biproduct.ι g k, ?_⟩ - show (∑ k : J, f k ≫ biproduct.ι g k) ≫ algUnitHom R (⨁ g) = y + 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 @@ -307,15 +319,17 @@ source. -/ theorem unitBij_biproduct_left [Category.{v} D] [MonoidalCategory D] [Preadditive D] [HasFiniteBiproducts D] (R : D) [MonObj R] - {J : Type} [Fintype J] - [DecidableEq J] (f : J → D) (W : D) + {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 ?_ - show (biproduct.ι f j ≫ x) ≫ algUnitHom R W = + change (biproduct.ι f j ≫ x) ≫ algUnitHom R W = (biproduct.ι f j ≫ y) ≫ algUnitHom R W rw [Category.assoc, Category.assoc, hxy'] · intro y @@ -323,7 +337,7 @@ theorem unitBij_biproduct_left have hg' : ∀ j : J, g j ≫ algUnitHom R W = biproduct.ι f j ≫ y := hg refine ⟨∑ j : J, biproduct.π f j ≫ g j, ?_⟩ - show (∑ j : J, biproduct.π f j ≫ g j) ≫ algUnitHom R W = y + 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 = @@ -351,7 +365,7 @@ theorem OddLine.hom_line_scalar (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 ?_⟩ - show f ▷ L.obj = (c • 𝟙 L.obj) ▷ L.obj + 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 ?_ @@ -451,7 +465,7 @@ theorem hom_line_freeLine_scalar ∃ 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 ?_⟩ - show g ▷ L.obj = (c • algUnitHom R L.obj) ▷ L.obj + 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 @@ -487,7 +501,7 @@ theorem unitBij_unit_unit · intro y obtain ⟨c, hc⟩ := halg (y ≫ (ρ_ R).hom) refine ⟨c • 𝟙 (𝟙_ D), ?_⟩ - show (c • 𝟙 (𝟙_ D)) ≫ algUnitHom R (𝟙_ D) = y + 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] @@ -504,7 +518,7 @@ theorem unitBij_unit_line rw [L.hom_unit_line_eq_zero hLU x, L.hom_unit_line_eq_zero hLU y] · intro y refine ⟨0, ?_⟩ - show (0 : 𝟙_ D ⟶ L.obj) ≫ algUnitHom R L.obj = y + 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 @@ -519,7 +533,7 @@ theorem unitBij_line_unit rw [hLU x, hLU y] · intro y refine ⟨0, ?_⟩ - show (0 : L.obj ⟶ 𝟙_ D) ≫ algUnitHom R (𝟙_ D) = y + change (0 : L.obj ⟶ 𝟙_ D) ≫ algUnitHom R (𝟙_ D) = y rw [Limits.zero_comp] exact (hom_line_freeUnit_eq_zero L R hLR y).symm @@ -548,7 +562,7 @@ theorem unitBij_line_line · intro y obtain ⟨c, hc⟩ := hom_line_freeLine_scalar L R halg y refine ⟨c • 𝟙 L.obj, ?_⟩ - show (c • 𝟙 L.obj) ≫ algUnitHom R L.obj = y + change (c • 𝟙 L.obj) ≫ algUnitHom R L.obj = y rw [Linear.smul_comp, Category.id_comp, hc] /-! ## Bijectivity at the mixed sums -/ @@ -561,7 +575,7 @@ theorem unitBij_mix_right (V : D) (h1 : UnitBij R V (𝟙_ D)) (h2 : UnitBij R V L.obj) (p q : ℕ) : UnitBij R V (L.mix p q) := by - show UnitBij R V (⨁ L.mixFun p q) + change UnitBij R V (⨁ L.mixFun p q) refine unitBij_biproduct_right R V (L.mixFun p q) ?_ rintro (i | j) · exact h1 @@ -579,7 +593,7 @@ theorem unitBij_mix [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (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 - show UnitBij R (⨁ L.mixFun p q) (L.mix p' q') + 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) @@ -604,7 +618,7 @@ theorem freeModHomEquiv_freeModMap {V W : D} (f : V ⟶ W) : freeModHomEquiv R V (freeMod R W) (freeModMap R f) = f ≫ algUnitHom R W := by - show (λ_ V).inv ≫ (η[R] ▷ V) ≫ (R ◁ f) = f ≫ algUnitHom R W + change (λ_ V).inv ≫ (η[R] ▷ V) ≫ (R ◁ f) = f ≫ algUnitHom R W rw [← Category.assoc] exact algUnitHom_naturality R f @@ -645,7 +659,7 @@ theorem freeModMap_injective_mix 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 ?_ - show f ≫ algUnitHom R (L.mix p' q') + change f ≫ algUnitHom R (L.mix p' q') = f' ≫ algUnitHom R (L.mix p' q') rw [← freeModHomEquiv_freeModMap, ← freeModHomEquiv_freeModMap, h'] @@ -735,7 +749,7 @@ theorem OddLine.mixEntry_comp = 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.zero_comp, Limits.comp_zero, + 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) @@ -781,21 +795,21 @@ theorem OddLine.mixMat_one · subst h rw [components_id_self] rcases j with i | jj - · show (1 : Matrix (Fin p) (Fin p) ℂ) i i • 𝟙 (𝟙_ D) = 𝟙 (𝟙_ D) + · change (1 : Matrix (Fin p) (Fin p) ℂ) i i • 𝟙 (𝟙_ D) = 𝟙 (𝟙_ D) rw [Matrix.one_apply_eq, one_smul] - · show (1 : Matrix (Fin q) (Fin q) ℂ) jj jj • 𝟙 L.obj = 𝟙 L.obj + · 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]) - show (1 : Matrix (Fin p) (Fin p) ℂ) i i2 • 𝟙 (𝟙_ D) = 0 + 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]) - show (1 : Matrix (Fin q) (Fin q) ℂ) jj j2 • 𝟙 L.obj = 0 + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeTwistPi.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeTwistPi.lean index 6ee7bed123..3e6d0544ad 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeTwistPi.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeTwistPi.lean @@ -61,7 +61,7 @@ theorem modTensorπ_freeTensorTwistIso have hπ : modTensorπ A (regularMod A) M ≫ (modTensorUnitLeft A M).hom = actLeft A M.X := modTensorπ_desc A (regularMod A) M _ _ - show modTensorπ A (freeMod A V) 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 ≫ @@ -70,7 +70,7 @@ theorem modTensorπ_freeTensorTwistIso ((β_ A V).hom ▷ M.X) ≫ (α_ V A M.X).hom ≫ (V ◁ actLeft A M.X) rw [modTensorπ_map_assoc, modTensorπ_twistShuffleHom_assoc] - show ((β_ A V).hom ⊗ₘ (λ_ M.X).inv) ≫ + 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) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaComplex.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaComplex.lean index 64ad137a1c..2429f53932 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaComplex.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaComplex.lean @@ -42,12 +42,12 @@ theorem exists_smul_one_of_simple_of_epi [MonoidalLinear ℂ (Ind C)] (hu : HasScalarUnit C) (hsmul : IndOfLinear C) (hlen : ∀ Z : C, ∃ N : ℕ, LengthLE Z N) - (L : OddLine (Ind C)) {𝔸 𝔹 : Ind C} [MonObj 𝔸] [MonObj 𝔹] + (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 - letI : Field ((gammaAlgebra (Ind C) L 𝔹).even) := + let : Field ((gammaAlgebra (Ind C) L 𝔹).even) := gammaEvenField 𝔹 L hsimple hne have hrank : Module.rank ℂ ((gammaAlgebra (Ind C) L 𝔹).even) ≤ Cardinal.aleph0 := diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaCountable.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaCountable.lean index 494188e229..516652859b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaCountable.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaCountable.lean @@ -107,7 +107,7 @@ theorem rank_le_aleph0_of_countable_cover rwa [(b i).span_eq, Submodule.map_top, Submodule.range_subtype] at h1 have hcS : (⋃ i, s i).Countable := by - haveI := hcnt + have := hcnt exact Set.countable_iUnion fun i => Set.countable_range _ have htopS : Submodule.span K (⋃ i, s i) = ⊤ := by rw [Submodule.span_iUnion] @@ -271,7 +271,7 @@ theorem rank_hom_unit_indOf_le_aleph0 (hu : HasScalarUnit C) (hsmul : IndOfLinear C) {W : C} (hW : ∃ N : ℕ, LengthLE W N) : Module.rank ℂ (𝟙_ (Ind C) ⟶ indOf.obj W) ≤ Cardinal.aleph0 := by - haveI : FiniteDimensional ℂ (𝟙_ C ⟶ W) := + 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) := @@ -344,9 +344,9 @@ theorem rank_hom_unit_tensor_presented Module.rank ℂ (𝟙_ (Ind C) ⟶ (Y ⊗ Z) ⊗ indOf.obj W) ≤ Cardinal.aleph0 := by obtain ⟨I, hcat, hfil, hcnt, G, ⟨eZ⟩⟩ := hZ - letI := hcat - letI := hfil - letI := hcnt + let := hcat + let := hfil + let := hcnt refine rank_hom_unit_le_aleph0_of_iso (Z := colimit (((G ⋙ indOf) ⋙ tensorRight (indOf.obj W)) ⋙ tensorLeft Y)) ?_ ?_ @@ -441,9 +441,9 @@ theorem exists_common_algebra_rank_le_aleph0 MonObj.one (X := 𝔸) ≠ 0 ∧ (∀ j, ∃ φ : B j ⟶ 𝔸, IsMonHom φ) ∧ Module.rank ℂ (𝟙_ (Ind C) ⟶ 𝔸) ≤ Cardinal.aleph0 := by - letI : DecidableRel (WellOrderingRel (α := J)) := + let : DecidableRel (WellOrderingRel (α := J)) := Classical.decRel _ - letI : LinearOrder J := linearOrderOfSTO WellOrderingRel + 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⟩, @@ -522,11 +522,11 @@ theorem exists_universal_algebra_rank_le_aleph0 classical choose pm qm Am Amon Acomm Ane Apres Aiso using hmix choose Bs Bmon Bcomm Bne Bpres Bsec using hsplit - letI : ∀ i : J ⊕ K, MonObj (Sum.elim Am Bs i) := fun i => + 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 - letI : ∀ i : J ⊕ K, IsCommMonObj (Sum.elim Am Bs i) := fun i => + 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 @@ -542,13 +542,13 @@ theorem exists_universal_algebra_rank_le_aleph0 refine ⟨𝔸, hmon, hcomm, hne, ?_, ?_, hrk⟩ · intro j obtain ⟨φ, hφ⟩ := hmap (Sum.inl j) - haveI : IsMonHom (show Am j ⟶ 𝔸 from φ) := hφ + 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) - haveI : IsMonHom (show Bs k ⟶ 𝔸 from φ) := hφ + 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 @@ -577,7 +577,7 @@ 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 - haveI := S.nontrivial_quotient_oddIdeal + 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 @@ -616,7 +616,7 @@ theorem nonempty_superPoint_gammaAlgebra (hR : MonObj.one (X := R) ≠ 0) (h : Module.rank ℂ (𝟙_ (Ind C) ⟶ R) ≤ Cardinal.aleph0) : Nonempty (SuperPoint (gammaAlgebra (Ind C) L R)) := by - haveI : Nontrivial (gammaAlgebra (Ind C) L R).even := + 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModuleFunctor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModuleFunctor.lean index 2f8653da38..85e74cc27f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModuleFunctor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModuleFunctor.lean @@ -37,12 +37,12 @@ noncomputable def gammaModuleFunctor map_id M := by refine SuperCommAlgebra.Mod.Hom.ext ?_ ?_ <;> refine LinearMap.ext fun m => ?_ <;> - · show m ≫ Mod.Hom.hom (𝟙 M) = 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 => ?_ <;> - · show m ≫ Mod.Hom.hom (f ≫ g) = (m ≫ f.hom) ≫ g.hom + · 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 index 70503e7f4d..fb8959c22b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPair.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPair.lean @@ -884,14 +884,14 @@ theorem gammaPairEven_actEE (gammaPairEven L R M N) := by refine liftEven_unique _ _ _ _ ?_ ?_ · intro m n - show gammaPairEven L R M N (tmulEE _ _ + 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 - show gammaPairEven L R M N (tmulOO _ _ + 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)) @@ -922,14 +922,14 @@ theorem gammaPairOdd_actEO (gammaPairOdd L R M N) := by refine liftOdd_unique _ _ _ _ ?_ ?_ · intro m n - show gammaPairOdd L R M N (tmulEO _ _ + 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 - show gammaPairOdd L R M N (tmulOE _ _ + 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)) @@ -961,14 +961,14 @@ theorem gammaPairOdd_actOE (gammaPairEven L R M N) := by refine liftEven_unique _ _ _ _ ?_ ?_ · intro m n - show gammaPairOdd L R M N (tmulOE _ _ + 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 - show gammaPairOdd L R M N (tmulEO _ _ + 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)) @@ -1000,14 +1000,14 @@ theorem gammaPairEven_actOO (gammaPairOdd L R M N) := by refine liftOdd_unique _ _ _ _ ?_ ?_ · intro m n - show gammaPairEven L R M N (tmulOO _ _ + 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 - show gammaPairEven L R M N (tmulEE _ _ + 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)) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairAdd.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairAdd.lean index d3f25900dc..e292ba45c4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairAdd.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairAdd.lean @@ -130,10 +130,10 @@ theorem sum_gammaModuleFunctor_map refine SuperCommAlgebra.Mod.Hom.ext ?_ ?_ <;> refine LinearMap.ext fun m => ?_ · rw [SuperCommAlgebra.Mod.sum_evenMap_apply] - show ∑ i ∈ s, m ≫ (g i).hom = m + change ∑ i ∈ s, m ≫ (g i).hom = m erw [← Preadditive.comp_sum, h, Category.comp_id] · rw [SuperCommAlgebra.Mod.sum_oddMap_apply] - show ∑ i ∈ s, m ≫ (g i).hom = m + change ∑ i ∈ s, m ≫ (g i).hom = m erw [← Preadditive.comp_sum, h, Category.comp_id] end Realize diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairNat.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairNat.lean index c4c39271b2..b980b9529b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairNat.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairNat.lean @@ -71,7 +71,7 @@ theorem gpair_naturality (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 - show ((m ≫ f.hom) ⊗ₘ (n ≫ g.hom)) ≫ modTensorπ R M' N' = + 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] @@ -336,11 +336,11 @@ theorem gammaPairComparison_isIso_of_iso (e : M ≅ M') (e' : N ≅ N') (h : IsIso (gammaPairComparison L R M' N')) : IsIso (gammaPairComparison L R M N) := by - haveI := h - haveI : IsIso (gammaFunMap L R (modTensorMapMod R e.hom e'.hom)) := + have := h + have : IsIso (gammaFunMap L R (modTensorMapMod R e.hom e'.hom)) := ((gammaModuleFunctor L R).mapIso (modTensorMapModIso R e e')).isIso_hom - haveI : IsIso (SuperCommAlgebra.Mod.tensorHom + have : IsIso (SuperCommAlgebra.Mod.tensorHom (gammaFunMap L R e.hom) (gammaFunMap L R e'.hom)) := (SuperCommAlgebra.Mod.tensorIso ((gammaModuleFunctor L R).mapIso e) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetract.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetract.lean index b0f276e7be..3052be4fc1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetract.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetract.lean @@ -75,7 +75,7 @@ theorem isIso_gammaPairComparison_of_retracts (h : ∀ i, IsIso (gammaPairComparison L R (M' i) N)) : IsIso (gammaPairComparison L R M N) := by classical - haveI := h + 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)) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetractRight.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetractRight.lean index 95642aa089..95f38bb821 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetractRight.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetractRight.lean @@ -129,7 +129,7 @@ theorem isIso_gammaPairComparison_of_retracts_right (h : ∀ i, IsIso (gammaPairComparison L R M (N' i))) : IsIso (gammaPairComparison L R M N) := by classical - haveI := h + 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) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaTwistLeft.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaTwistLeft.lean index b250762b2e..6627dc9e69 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaTwistLeft.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaTwistLeft.lean @@ -237,7 +237,7 @@ noncomputable def OddLine.capLEquiv invFun h := (λ_ Y).inv ≫ (L.sq.inv ▷ Y) ≫ (α_ L.obj L.obj Y).hom ≫ (L.obj ◁ h) left_inv f := by - letI := L.exactPairing + 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 @@ -245,11 +245,11 @@ noncomputable def OddLine.capLEquiv (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 - show (λ_ Y).inv ≫ (L.sq.inv ▷ Y) ≫ (α_ L.obj L.obj Y).hom ≫ + 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 - letI := L.exactPairing + 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 @@ -257,7 +257,7 @@ noncomputable def OddLine.capLEquiv (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 - show (L.obj ◁ ((λ_ Y).inv ≫ (L.sq.inv ▷ Y) ≫ + 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] @@ -280,7 +280,7 @@ theorem gammaTwistLeftEven_apply (f : 𝟙_ D ⟶ L.obj ⊗ Z) : (gammaTwistLeftEven L Z).toLinearMap f = (ρ_ L.obj).inv ≫ (L.obj ◁ f) ≫ L.capL Z := by - show gammaTwistLeftEven L Z f = _ + change gammaTwistLeftEven L Z f = _ rw [gammaTwistLeftEven, LinearEquiv.trans_apply, Linear.homCongr_apply, Iso.refl_hom, Category.comp_id] rfl @@ -306,7 +306,7 @@ theorem gammaTwistLeftOdd_apply (g : L.obj ⟶ L.obj ⊗ Z) : (gammaTwistLeftOdd L Z).toLinearMap g = (-L.sq.inv) ≫ (L.obj ◁ g) ≫ L.capL Z := by - show gammaTwistLeftOdd L Z g = _ + 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, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GeneratorAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GeneratorAlgebra.lean index 0b66db7a13..dad84b5d92 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GeneratorAlgebra.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GeneratorAlgebra.lean @@ -59,10 +59,10 @@ theorem exists_generator_algebra η[𝔸] ≠ 0 ∧ CountablyPresented 𝔸 ∧ Nonempty (freeMod 𝔸 ((indOf : C ⥤ Ind C).obj X₀) ≅ freeMod 𝔸 (L.mix p q)) := by - letI := linearOfScalarUnit ψ - letI := monoidalLinearOfScalarUnitBraided ψ - letI := linearOfScalarUnit (indScalarUnit ψ) - letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/HomFinite.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HomFinite.lean index bf69247b44..3691330a15 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/HomFinite.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HomFinite.lean @@ -116,8 +116,8 @@ theorem nonempty_unitIso_of_hom_ne_zero (hu : HasScalarUnit A) {S : A} [Simple S] {φ : 𝟙_ A ⟶ S} (hφ : φ ≠ 0) : Nonempty (𝟙_ A ≅ S) := by - haveI : Simple (𝟙_ A) := simple_unit_of_hasScalarUnit hu - haveI : IsIso φ := isIso_of_hom_simple hφ + 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 @@ -149,7 +149,7 @@ theorem finrank_hom_unit_simple_eq_zero (hu : HasScalarUnit A) {S : A} [Simple S] (h : IsEmpty (𝟙_ A ≅ S)) : Module.finrank ℂ (𝟙_ A ⟶ S) = 0 := by - haveI := subsingleton_hom_unit_simple hu h + have := subsingleton_hom_unit_simple hu h exact Module.finrank_zero_of_subsingleton end Proportional @@ -295,18 +295,18 @@ private theorem homFinite_core ∀ (N : ℕ) (Z : A), LengthLE Z N → Module.Finite ℂ (𝟙_ A ⟶ Z) ∧ Module.finrank ℂ (𝟙_ A ⟶ Z) ≤ N := by - haveI := hs + have := hs intro N induction N with | zero => intro Z h rcases subsingleton_or_nontrivial (𝟙_ A ⟶ Z) with hss | hnt - · haveI := hss + · have := hss exact ⟨inferInstance, by rw [Module.finrank_zero_of_subsingleton]⟩ - · haveI := hnt + · have := hnt obtain ⟨φ, hφ⟩ := exists_ne (0 : 𝟙_ A ⟶ Z) - haveI : Mono φ := mono_of_nonzero_from_simple hφ + 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 @@ -319,14 +319,14 @@ private theorem homFinite_core | succ M ih => intro Z h rcases subsingleton_or_nontrivial (𝟙_ A ⟶ Z) with hss | hnt - · haveI := hss + · have := hss exact ⟨inferInstance, by rw [Module.finrank_zero_of_subsingleton]; exact Nat.zero_le _⟩ - · haveI := hnt + · have := hnt obtain ⟨φ, hφ⟩ := exists_ne (0 : 𝟙_ A ⟶ Z) - haveI : Mono φ := mono_of_nonzero_from_simple hφ + have : Mono φ := mono_of_nonzero_from_simple hφ obtain ⟨hfinQ, hrkQ⟩ := ih (cokernel φ) (lengthLE_cokernel φ hφ h) - haveI := hfinQ + have := hfinQ set L : (𝟙_ A ⟶ Z) →ₗ[ℂ] (𝟙_ A ⟶ cokernel φ) := Linear.rightComp ℂ (𝟙_ A) (cokernel.π φ) with hLdef have hker : LinearMap.ker L ≤ Submodule.span ℂ {φ} := by @@ -336,11 +336,11 @@ private theorem homFinite_core 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⟩ - haveI hkfin : FiniteDimensional ℂ (LinearMap.ker L) := + have hkfin : FiniteDimensional ℂ (LinearMap.ker L) := Submodule.finiteDimensional_of_le hker - haveI hrfin : FiniteDimensional ℂ (LinearMap.range L) := + have hrfin : FiniteDimensional ℂ (LinearMap.range L) := inferInstance - haveI hfin : Module.Finite ℂ (𝟙_ A ⟶ Z) := + 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] @@ -404,7 +404,7 @@ theorem finrank_hom_le (h : LengthLE (Y ⊗ Xᘁ) N) : Module.Finite ℂ (X ⟶ Y) ∧ Module.finrank ℂ (X ⟶ Y) ≤ N := by obtain ⟨hfin, hrk⟩ := finrank_hom_unit_le hu h - haveI := hfin + have := hfin refine ⟨Module.Finite.equiv (homUnitDualEquiv X Y).symm, ?_⟩ rw [(homUnitDualEquiv X Y).finrank_eq] exact hrk diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookMult.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookMult.lean index 5e359d2212..b26ee8287f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookMult.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookMult.lean @@ -34,7 +34,7 @@ theorem eq_zero_of_sum_nat_eq_zero {ι : Type*} {s : Finset ι} ((if h' : i ∈ s then Classical.choose (h i h') else 0 : ℕ) : ℂ) := by intro i hi - rw [dif_pos 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) : ℕ) : diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookZero.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookZero.lean index f5063a0c55..94fead8564 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookZero.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookZero.lean @@ -52,7 +52,7 @@ theorem hookColOp_blockTriangular (p ℓ : ℕ) : /-- The column operation has determinant one. -/ theorem det_hookColOp (p ℓ : ℕ) : (hookColOp p ℓ).det = 1 := by - rw [Matrix.det_of_upperTriangular (hookColOp_blockTriangular p ℓ)] + rw [Matrix.det_of_isUpperTriangular (hookColOp_blockTriangular p ℓ)] apply Finset.prod_eq_one intro j _ simp only [hookColOp, Matrix.of_apply] @@ -107,8 +107,8 @@ theorem jtMatrix_mul_hookColOp (t : ℕ → ℂ) (rows : List ℕ) (p : ℕ) 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, if_neg hnotlt, - if_neg hkj, mul_zero])).symm] + 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 : ℕ)) @@ -124,17 +124,17 @@ theorem jtMatrix_mul_hookColOp (t : ℕ → ℂ) (rows : List ℕ) (p : ℕ) · intro k hk rw [Finset.mem_filter] at hk refine Fin.ext ?_ - show (j : ℕ) - ((j : ℕ) - (k : ℕ)) = (k : ℕ) + change (j : ℕ) - ((j : ℕ) - (k : ℕ)) = (k : ℕ) omega · intro d hd rw [Finset.mem_range] at hd - show (j : ℕ) - ((j : ℕ) - d) = d + 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, if_neg hnotlt, - if_pos hkj] + 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] @@ -214,14 +214,14 @@ theorem diagramSchur_eq_zero_of_hook (t : ℕ → ℂ) {p q : ℕ} apply hc₀ calc c i₀ = w ⟨(i₀ : ℕ), lt_of_lt_of_le i₀.isLt hpl⟩ := by rw [hw] - show c i₀ = + change c i₀ = if h : (i₀ : ℕ) < p + 1 then c ⟨(i₀ : ℕ), h⟩ else 0 - rw [dif_pos i₀.isLt] + 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 - show ∑ k, w k * M k j = 0 + 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 * @@ -237,7 +237,7 @@ theorem diagramSchur_eq_zero_of_hook (t : ℕ → ℂ) {p q : ℕ} 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 - show c a * (jtMatrix t lam.rowLens * + 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] @@ -250,7 +250,7 @@ theorem diagramSchur_eq_zero_of_hook (t : ℕ → ℂ) {p q : ℕ} rw [Finset.mem_filter, not_and] at hk have : ¬ (k : ℕ) < p + 1 := hk (Finset.mem_univ k) rw [hw] - simp only [dif_neg this, zero_mul])).symm] + 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))) @@ -269,7 +269,7 @@ theorem diagramSchur_eq_zero_of_hook (t : ℕ → ℂ) {p q : ℕ} · intro k hk have hklt : (k : ℕ) < p + 1 := (Finset.mem_filter.mp hk).2 rw [hw] - simp only [dif_pos hklt] + simp only [dite_eq_left hklt] rfl -- Conclude through the determinant. have hdet0 : M.det = 0 := @@ -314,7 +314,7 @@ theorem superPS_rec_int (p q : ℕ) {m : ℤ} (hm : (q : ℤ) < m) : omega · rw [Finset.mem_range, not_lt] at hd have hneg : m - (d : ℤ) < 0 := by omega - rw [newtonHZ, if_neg (not_le.mpr hneg), mul_zero] + 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 : ℤ))) = @@ -343,24 +343,24 @@ 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 [if_pos h] + · 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_upperTriangular + 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 _ => ?_ - show newtonHZ (superPS 1 0) + 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 [if_neg h] + · rw [ite_eq_right h] exact diagramSchur_superPS_eq_zero ν (YoungDiagram.mem_iff_lt_colLen.mpr (by omega)) @@ -370,7 +370,7 @@ 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 [if_pos h] + · rw [ite_eq_left h] have hone : ∀ i : Fin ν.rowLens.length, ν.rowLens.get i = 1 := by intro i @@ -384,10 +384,10 @@ theorem diagramSchur_superPS_col (ν : YoungDiagram) : newtonH (superPS 0 1) n = ((1 : ℕ).choose n : ℂ) := newtonH_superPS_zero_p 1 rw [diagramSchur, schurDet_eq_det_jtMatrix, - Matrix.det_of_lowerTriangular _ (by + Matrix.det_of_isLowerTriangular _ (by intro i j hij have hij' : (i : ℕ) < (j : ℕ) := hij - show newtonHZ (superPS 0 1) + change newtonHZ (superPS 0 1) ((ν.rowLens.get i : ℤ) + (j : ℤ) - (i : ℤ)) = 0 rw [hone i, show ((1 : ℕ) : ℤ) + (j : ℤ) - (i : ℤ) = ((1 + (j : ℕ) - (i : ℕ) : ℕ) : ℤ) by omega, @@ -395,12 +395,12 @@ theorem diagramSchur_superPS_col (ν : YoungDiagram) : rw [Nat.choose_eq_zero_of_lt (by omega)] simp)] refine Finset.prod_eq_one fun i _ => ?_ - show newtonHZ (superPS 0 1) + 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 [if_neg h] + · rw [ite_eq_right h] exact diagramSchur_superPS_eq_zero ν (YoungDiagram.mem_iff_lt_rowLen.mpr (by omega)) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean index b27526d3d7..3e19073415 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean @@ -390,13 +390,13 @@ theorem tensorPowMap_concat (tensorPowConcat X a b).hom ≫ tensorPowMap f (a + b) | 0 => by rw [tensorPowConcat_zero, tensorPowConcat_zero] - show (tensorPowMap f a ⊗ₘ 𝟙 (𝟙_ D)) ≫ + 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 - show (tensorPowMap f a ⊗ₘ (tensorPowMap f b ⊗ₘ f)) ≫ + 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 ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdempotentLength.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdempotentLength.lean index 3542c461d7..64953c1a9d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdempotentLength.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdempotentLength.lean @@ -51,7 +51,7 @@ private def extendZero [Category.{v} C] [Abelian C] 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⟩ := - dif_pos h + dite_eq_left h /-- The extension by zero inherits idempotence. -/ private lemma extendZero_idem [Category.{v} C] [Abelian C] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ImageSubalgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ImageSubalgebra.lean index 4b61e9f9e2..e96482104e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ImageSubalgebra.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ImageSubalgebra.lean @@ -155,8 +155,8 @@ instance epi_tensorHom_ind [MonoidalPreadditive C] {X Y X' Y' : Ind C} (f : X ⟶ Y) (g : X' ⟶ Y') [Epi f] [Epi g] : Epi (f ⊗ₘ g) := by - haveI : Epi (f ▷ X') := inferInstanceAs (Epi ((tensorRight X').map f)) - haveI : Epi (Y ◁ g) := inferInstanceAs (Epi ((tensorLeft Y).map g)) + 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 _ _ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCoeq.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCoeq.lean index 7a49a6a4aa..f5e53aa9a8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCoeq.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCoeq.lean @@ -150,7 +150,7 @@ lemma preservesColimit_flip_lim refine (Category.assoc _ _ _).trans ?_ refine (congrArg (fun t => colimit.ι (G.flip ⋙ lim) a ≫ t) (Category.assoc _ _ _)).trans ?_ - refine (HasColimit.isoOfNatIso_ι_hom_assoc + refine (HasColimit.ι_isoOfNatIso_hom_assoc (limitIsoFlipCompLim G).symm a _).trans ?_ refine (congrArg (fun t => (limitIsoFlipCompLim G).symm.hom.app a ≫ t) @@ -159,7 +159,7 @@ lemma preservesColimit_flip_lim apply congrArg (fun t => t ≫ (colimit.ι G.flip a).app b) simp [limitIsoFlipCompLim, Category.assoc] exact hL.trans hR.symm - haveI : IsIso (colimit.post G.flip lim) := by + have : IsIso (colimit.post G.flip lim) := by rw [key] exact IsIso.comp_isIso exact preservesColimit_of_isIso_post _ _ @@ -295,12 +295,12 @@ lemma preservesColimit_parallelPair_tensorLeft_indOf obtain ⟨P⟩ := nonempty_indParallelPairPresentation (Ind.isIndObject_inclusion_obj X) (Ind.isIndObject_inclusion_obj Y) ((Ind.inclusion C).map f) ((Ind.inclusion C).map g) - haveI : PreservesColimitsOfSize.{0, 0} (tensorLeft a) := + have : PreservesColimitsOfSize.{0, 0} (tensorLeft a) := preservesSmallestColimits_of_preservesColimits _ - haveI : PreservesColimit (parallelPair P.φ P.ψ) + have : PreservesColimit (parallelPair P.φ P.ψ) (Ind.lim P.I ⋙ tensorLeft (indOf.obj a)) := preservesColimit_of_natIso _ (indLimCompTensorLeftIso a P.I).symm - haveI : PreservesColimit (parallelPair P.φ P.ψ ⋙ Ind.lim P.I) + have : PreservesColimit (parallelPair P.φ P.ψ ⋙ Ind.lim P.I) (tensorLeft (indOf.obj a)) := preservesColimit_comp_diagram _ _ _ exact preservesColimit_of_iso_diagram _ @@ -319,12 +319,12 @@ lemma preservesLimit_parallelPair_tensorLeft_indOf obtain ⟨P⟩ := nonempty_indParallelPairPresentation (Ind.isIndObject_inclusion_obj X) (Ind.isIndObject_inclusion_obj Y) ((Ind.inclusion C).map f) ((Ind.inclusion C).map g) - haveI : PreservesLimitsOfSize.{0, 0} (tensorLeft a) := + have : PreservesLimitsOfSize.{0, 0} (tensorLeft a) := preservesSmallestLimits_of_preservesLimits _ - haveI : PreservesLimit (parallelPair P.φ P.ψ) + have : PreservesLimit (parallelPair P.φ P.ψ) (Ind.lim P.I ⋙ tensorLeft (indOf.obj a)) := preservesLimit_of_natIso _ (indLimCompTensorLeftIso a P.I).symm - haveI : PreservesLimit (parallelPair P.φ P.ψ ⋙ Ind.lim P.I) + have : PreservesLimit (parallelPair P.φ P.ψ ⋙ Ind.lim P.I) (tensorLeft (indOf.obj a)) := preservesLimit_comp_diagram _ _ _ exact preservesLimit_of_iso_diagram _ @@ -339,12 +339,12 @@ lemma preservesLimit_parallelPair_tensorRight_indOf obtain ⟨P⟩ := nonempty_indParallelPairPresentation (Ind.isIndObject_inclusion_obj X) (Ind.isIndObject_inclusion_obj Y) ((Ind.inclusion C).map f) ((Ind.inclusion C).map g) - haveI : PreservesLimitsOfSize.{0, 0} (tensorRight a) := + have : PreservesLimitsOfSize.{0, 0} (tensorRight a) := preservesSmallestLimits_of_preservesLimits _ - haveI : PreservesLimit (parallelPair P.φ P.ψ) + have : PreservesLimit (parallelPair P.φ P.ψ) (Ind.lim P.I ⋙ tensorRight (indOf.obj a)) := preservesLimit_of_natIso _ (indLimCompTensorRightIso a P.I).symm - haveI : PreservesLimit (parallelPair P.φ P.ψ ⋙ Ind.lim P.I) + have : PreservesLimit (parallelPair P.φ P.ψ ⋙ Ind.lim P.I) (tensorRight (indOf.obj a)) := preservesLimit_comp_diagram _ _ _ exact preservesLimit_of_iso_diagram _ @@ -359,12 +359,12 @@ lemma preservesColimit_parallelPair_tensorRight_indOf obtain ⟨P⟩ := nonempty_indParallelPairPresentation (Ind.isIndObject_inclusion_obj X) (Ind.isIndObject_inclusion_obj Y) ((Ind.inclusion C).map f) ((Ind.inclusion C).map g) - haveI : PreservesColimitsOfSize.{0, 0} (tensorRight a) := + have : PreservesColimitsOfSize.{0, 0} (tensorRight a) := preservesSmallestColimits_of_preservesColimits _ - haveI : PreservesColimit (parallelPair P.φ P.ψ) + have : PreservesColimit (parallelPair P.φ P.ψ) (Ind.lim P.I ⋙ tensorRight (indOf.obj a)) := preservesColimit_of_natIso _ (indLimCompTensorRightIso a P.I).symm - haveI : PreservesColimit (parallelPair P.φ P.ψ ⋙ Ind.lim P.I) + have : PreservesColimit (parallelPair P.φ P.ψ ⋙ Ind.lim P.I) (tensorRight (indOf.obj a)) := preservesColimit_comp_diagram _ _ _ exact preservesColimit_of_iso_diagram _ @@ -426,7 +426,7 @@ def whiskerLeftPairFunctorEvalIso tensorRight ((parallelPair f g).obj k) := NatIso.ofComponents (fun _ => Iso.refl _) (fun u => by - show u ▷ (parallelPair f g).obj k ≫ 𝟙 _ = + change u ▷ (parallelPair f g).obj k ≫ 𝟙 _ = 𝟙 _ ≫ u ▷ (parallelPair f g).obj k rw [Category.comp_id, Category.id_comp]) @@ -440,7 +440,7 @@ def whiskerRightPairFunctorEvalIso tensorLeft ((parallelPair f g).obj k) := NatIso.ofComponents (fun _ => Iso.refl _) (fun u => by - show (parallelPair f g).obj k ◁ u ≫ 𝟙 _ = + change (parallelPair f g).obj k ◁ u ≫ 𝟙 _ = 𝟙 _ ≫ (parallelPair f g).obj k ◁ u rw [Category.comp_id, Category.id_comp]) @@ -475,21 +475,21 @@ def whiskerLeftCoeqComparison tensorRight (colimit (parallelPair f g)) where app A := colimit.post (parallelPair f g) (tensorLeft A) naturality {A B} u := by - show colimMap ((whiskerLeftPairFunctor f g).map u) ≫ + 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] - show ((whiskerLeftPairFunctor f g).map u).app k ≫ + 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] - show u ▷ (parallelPair f g).obj k ≫ + change u ▷ (parallelPair f g).obj k ≫ (B ◁ colimit.ι (parallelPair f g) k) = (A ◁ colimit.ι (parallelPair f g) k) ≫ u ▷ colimit (parallelPair f g) @@ -505,21 +505,21 @@ def whiskerRightCoeqComparison tensorLeft (colimit (parallelPair f g)) where app A := colimit.post (parallelPair f g) (tensorRight A) naturality {A B} u := by - show colimMap ((whiskerRightPairFunctor f g).map u) ≫ + 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] - show ((whiskerRightPairFunctor f g).map u).app k ≫ + 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] - show (parallelPair f g).obj k ◁ u ≫ + change (parallelPair f g).obj k ◁ u ≫ (colimit.ι (parallelPair f g) k ▷ B) = (colimit.ι (parallelPair f g) k ▷ A) ≫ colimit (parallelPair f g) ◁ u @@ -533,17 +533,17 @@ lemma isIso_post_parallelPair_tensorLeft {X : Ind C} {Y : Ind C} (A : Ind C) (f g : X ⟶ Y) : IsIso (colimit.post (parallelPair f g) (tensorLeft A)) := by - haveI : PreservesFilteredColimits (whiskerLeftPairFunctor f g) := + have : PreservesFilteredColimits (whiskerLeftPairFunctor f g) := preservesFilteredColimits_whiskerLeftPairFunctor f g - haveI : PreservesColimitsOfSize.{v, v} + have : PreservesColimitsOfSize.{v, v} (colim : (WalkingParallelPair ⥤ Ind C) ⥤ Ind C) := colimConstAdj.leftAdjoint_preservesColimits - haveI : PreservesFilteredColimits + have : PreservesFilteredColimits (whiskerLeftPairFunctor f g ⋙ colim) := ⟨fun _ _ _ => inferInstance⟩ have h := isIso_app_of_isIso_indOf (whiskerLeftCoeqComparison f g) (fun c => by - haveI := preservesColimit_parallelPair_tensorLeft_indOf c f g + have := preservesColimit_parallelPair_tensorLeft_indOf c f g exact inferInstanceAs (IsIso (colimit.post (parallelPair f g) (tensorLeft (indOf.obj c))))) A exact h @@ -554,17 +554,17 @@ lemma isIso_post_parallelPair_tensorRight {X : Ind C} {Y : Ind C} (A : Ind C) (f g : X ⟶ Y) : IsIso (colimit.post (parallelPair f g) (tensorRight A)) := by - haveI : PreservesFilteredColimits (whiskerRightPairFunctor f g) := + have : PreservesFilteredColimits (whiskerRightPairFunctor f g) := preservesFilteredColimits_whiskerRightPairFunctor f g - haveI : PreservesColimitsOfSize.{v, v} + have : PreservesColimitsOfSize.{v, v} (colim : (WalkingParallelPair ⥤ Ind C) ⥤ Ind C) := colimConstAdj.leftAdjoint_preservesColimits - haveI : PreservesFilteredColimits + have : PreservesFilteredColimits (whiskerRightPairFunctor f g ⋙ colim) := ⟨fun _ _ _ => inferInstance⟩ have h := isIso_app_of_isIso_indOf (whiskerRightCoeqComparison f g) (fun c => by - haveI := preservesColimit_parallelPair_tensorRight_indOf c f g + have := preservesColimit_parallelPair_tensorRight_indOf c f g exact inferInstanceAs (IsIso (colimit.post (parallelPair f g) (tensorRight (indOf.obj c))))) A exact h @@ -579,10 +579,10 @@ instance tensorLeft_ind_preservesCoequalizers (A : Ind C) : PreservesColimitsOfShape WalkingParallelPair (tensorLeft A) where preservesColimit {K} := by - haveI := isIso_post_parallelPair_tensorLeft A + have := isIso_post_parallelPair_tensorLeft A (K.map WalkingParallelPairHom.left) (K.map WalkingParallelPairHom.right) - haveI : PreservesColimit + have : PreservesColimit (parallelPair (K.map WalkingParallelPairHom.left) (K.map WalkingParallelPairHom.right)) (tensorLeft A) := preservesColimit_of_isIso_post _ _ @@ -595,10 +595,10 @@ instance tensorRight_ind_preservesCoequalizers (A : Ind C) : PreservesColimitsOfShape WalkingParallelPair (tensorRight A) where preservesColimit {K} := by - haveI := isIso_post_parallelPair_tensorRight A + have := isIso_post_parallelPair_tensorRight A (K.map WalkingParallelPairHom.left) (K.map WalkingParallelPairHom.right) - haveI : PreservesColimit + have : PreservesColimit (parallelPair (K.map WalkingParallelPairHom.left) (K.map WalkingParallelPairHom.right)) (tensorRight A) := preservesColimit_of_isIso_post _ _ @@ -619,10 +619,10 @@ lemma preservesColimitsOfShape_parallelPairLim_ind [SmallCategory C] [Abelian C] (I : Type v) [SmallCategory I] [IsFiltered I] : PreservesColimitsOfShape I (lim : (WalkingParallelPair ⥤ Ind C) ⥤ Ind C) := by - haveI hlim : PreservesColimitsOfShape I + have hlim : PreservesColimitsOfShape I (lim : (WalkingParallelPair ⥤ (Cᵒᵖ ⥤ Type v)) ⥤ _) := preservesColimitsOfShape_lim - haveI h₁ : PreservesColimitsOfShape I + have h₁ : PreservesColimitsOfShape I ((lim : (WalkingParallelPair ⥤ Ind C) ⥤ Ind C) ⋙ Ind.inclusion C) := by exact preservesColimitsOfShape_of_natIso @@ -716,16 +716,16 @@ lemma isIso_limitPost_parallelPair_tensorLeft (A : Ind C) (f g : X ⟶ Y) : IsIso (limit.post (parallelPair f g) (tensorLeft A)) := by - haveI : PreservesFilteredColimits (whiskerLeftPairFunctor f g) := + have : PreservesFilteredColimits (whiskerLeftPairFunctor f g) := preservesFilteredColimits_whiskerLeftPairFunctor f g - haveI : PreservesFilteredColimits + have : PreservesFilteredColimits (whiskerLeftPairFunctor f g ⋙ lim) := ⟨fun I _ _ => by - haveI := preservesColimitsOfShape_parallelPairLim_ind (C := C) I + have := preservesColimitsOfShape_parallelPairLim_ind (C := C) I infer_instance⟩ have h := isIso_app_of_isIso_indOf (whiskerLeftEqComparison f g) (fun c => by - haveI := preservesLimit_parallelPair_tensorLeft_indOf c f g + have := preservesLimit_parallelPair_tensorLeft_indOf c f g exact inferInstanceAs (IsIso (limit.post (parallelPair f g) (tensorLeft (indOf.obj c))))) A exact h @@ -737,16 +737,16 @@ lemma isIso_limitPost_parallelPair_tensorRight (A : Ind C) (f g : X ⟶ Y) : IsIso (limit.post (parallelPair f g) (tensorRight A)) := by - haveI : PreservesFilteredColimits (whiskerRightPairFunctor f g) := + have : PreservesFilteredColimits (whiskerRightPairFunctor f g) := preservesFilteredColimits_whiskerRightPairFunctor f g - haveI : PreservesFilteredColimits + have : PreservesFilteredColimits (whiskerRightPairFunctor f g ⋙ lim) := ⟨fun I _ _ => by - haveI := preservesColimitsOfShape_parallelPairLim_ind (C := C) I + have := preservesColimitsOfShape_parallelPairLim_ind (C := C) I infer_instance⟩ have h := isIso_app_of_isIso_indOf (whiskerRightEqComparison f g) (fun c => by - haveI := preservesLimit_parallelPair_tensorRight_indOf c f g + have := preservesLimit_parallelPair_tensorRight_indOf c f g exact inferInstanceAs (IsIso (limit.post (parallelPair f g) (tensorRight (indOf.obj c))))) A exact h @@ -761,10 +761,10 @@ instance tensorLeft_ind_preservesEqualizers (A : Ind C) : PreservesLimitsOfShape WalkingParallelPair (tensorLeft A) where preservesLimit {K} := by - haveI := isIso_limitPost_parallelPair_tensorLeft A + have := isIso_limitPost_parallelPair_tensorLeft A (K.map WalkingParallelPairHom.left) (K.map WalkingParallelPairHom.right) - haveI : PreservesLimit + have : PreservesLimit (parallelPair (K.map WalkingParallelPairHom.left) (K.map WalkingParallelPairHom.right)) (tensorLeft A) := preservesLimit_of_isIso_post _ _ @@ -777,10 +777,10 @@ instance tensorRight_ind_preservesEqualizers (A : Ind C) : PreservesLimitsOfShape WalkingParallelPair (tensorRight A) where preservesLimit {K} := by - haveI := isIso_limitPost_parallelPair_tensorRight A + have := isIso_limitPost_parallelPair_tensorRight A (K.map WalkingParallelPairHom.left) (K.map WalkingParallelPairHom.right) - haveI : PreservesLimit + have : PreservesLimit (parallelPair (K.map WalkingParallelPairHom.left) (K.map WalkingParallelPairHom.right)) (tensorRight A) := preservesLimit_of_isIso_post _ _ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCompact.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCompact.lean index 4469b8c169..be23d7723a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCompact.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCompact.lean @@ -63,7 +63,7 @@ noncomputable def indOfCoyonedaIso [SmallCategory C] ((Ind.yonedaCompInclusion.app X).homCongr (Iso.refl _)))) (fun h => by ext f - show (Ind.yonedaCompInclusion.app X).inv ≫ + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndImage.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndImage.lean index d3ca7c49f1..4dd129dd0a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndImage.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndImage.lean @@ -245,7 +245,7 @@ theorem indImageEmbedded_of_lengthLE [SmallCategory C] [Abelian C] CategoryTheory.Functor.map_comp, hu, hv] exact ((Category.assoc _ _ _).symm.trans hβ).trans (Category.assoc _ _ _) - haveI : Mono (image.ι (g ≫ Z.presentation.F.map α₀) ≫ + 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 = @@ -253,8 +253,8 @@ theorem indImageEmbedded_of_lengthLE [SmallCategory C] [Abelian C] (cancel_mono (image.ι (g ≫ Z.presentation.F.map α₀) ≫ Z.presentation.F.map β)).mp hpre rw [← hu, ← hv, this] - haveI := hmono - haveI : StrongEpi (indOf.map + have := hmono + have : StrongEpi (indOf.map (factorThruImage (g ≫ Z.presentation.F.map α₀))) := strongEpi_of_epi _ refine ⟨image (g ≫ Z.presentation.F.map α₀), ⟨(image.isoStrongEpiMono diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean index 9bf6a57074..8bc82f3cb9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean @@ -34,18 +34,21 @@ private theorem ma_smul_apply {G : Type*} (r : ℂ) /-- 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] [DecidableEq G] (x : MonoidAlgebra ℂ G) : + [Fintype G] (x : MonoidAlgebra ℂ G) : LinearMap.trace ℂ (MonoidAlgebra ℂ G) (LinearMap.mulLeft ℂ x) = - (Fintype.card G : ℂ) * x.coeff 1 := - trace_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] - [Fintype G] [DecidableEq G] {x : MonoidAlgebra ℂ 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] @@ -87,7 +90,7 @@ theorem shape_e_coeff_conj (P : SchurPackage.{u}) {n : ℕ} ((permCast lam.prop.symm g)⁻¹ : _) (permCast lam.prop.symm k) simpa [inv_inv] using this - show (Shape.e P lam).coeff (g⁻¹ * k * g) = + change (Shape.e P lam).coeff (g⁻¹ * k * g) = (Shape.e P lam).coeff k rw [h1, h2, hchar] @@ -131,13 +134,13 @@ theorem blockImages_comm {a b : ℕ} (x : SymGroupAlgebra a) have hL : MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedFstHom a b) (MonoidAlgebra.single σ 1) = MonoidAlgebra.single (blockEmbed σ 1) (1 : ℂ) := by - show MonoidAlgebra.mapDomain _ + 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 - show MonoidAlgebra.mapDomain _ + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single τ 1) = _ exact MonoidAlgebra.mapDomain_single simp only [MonoidAlgebra.of_apply] @@ -231,8 +234,8 @@ theorem blockAlgEmbed_apply_blockEmbed {a b : ℕ} intro he exact hcase (blockEmbed_inj he) rcases not_and_or.mp hcase with hσ | hτ - · simp [MonoidAlgebra.coeff_single_apply, hne, hσ] - · simp [MonoidAlgebra.coeff_single_apply, hne, 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] @@ -275,7 +278,7 @@ theorem blockAlgEmbed_apply_eq_zero {a b : ℕ} /-- Convolution at the identity. -/ theorem mul_apply_one {G : Type*} [Group G] [Fintype G] - [DecidableEq G] (x y : MonoidAlgebra ℂ 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] @@ -301,7 +304,7 @@ theorem shape_e_mul_block_apply_one (P : SchurPackage.{u}) (Shape.e P lam).coeff g⁻¹ * (blockAlgEmbed (Shape.e P μ) (Shape.e P ν)).coeff g := Fintype.sum_equiv (Equiv.inv _) _ _ fun g => by - show (Shape.e P lam).coeff g * + 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⁻¹ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndLocallyMixed.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndLocallyMixed.lean index aea8c95d9a..fd8f18e841 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndLocallyMixed.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndLocallyMixed.lean @@ -39,9 +39,9 @@ theorem locallyMixed_indOf letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) ∀ (L : OddLine (Ind C)), ¬ IsZero (𝟙_ (Ind C)) → L.LocallyMixed ((indOf : C ⥤ Ind C).obj Z) := by - letI := linearOfScalarUnit ψ - letI := linearOfScalarUnit (indScalarUnit ψ) - letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + 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, ?_⟩ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndMonoidal.lean index 0b37e73110..2293486fce 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndMonoidal.lean @@ -105,7 +105,7 @@ instance symmetricCategoryOp {D : Type*} [Category D] [MonoidalCategory D] [SymmetricCategory D] : SymmetricCategory Dᵒᵖ where symmetry X Y := by - show (β_ (Opposite.unop Y) (Opposite.unop X)).hom.op ≫ + change (β_ (Opposite.unop Y) (Opposite.unop X)).hom.op ≫ (β_ (Opposite.unop X) (Opposite.unop Y)).hom.op = 𝟙 _ rw [← op_comp, SymmetricCategory.symmetry] rfl diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfLinear.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfLinear.lean index 44755ec043..02ed9bc72a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfLinear.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfLinear.lean @@ -74,8 +74,8 @@ theorem indOf_linear [SmallCategory C] [MonoidalCategory C] [Preadditive C] ∀ {X Y : C} (c : ℂ) (f : X ⟶ Y), (indOf : C ⥤ Ind C).map (c • f) = c • (indOf : C ⥤ Ind C).map f := by - letI := linearOfScalarUnit ψ - letI := linearOfScalarUnit (indScalarUnit ψ) + let := linearOfScalarUnit ψ + let := linearOfScalarUnit (indScalarUnit ψ) intro X Y c f exact indOf_map_scalarSmul ψ c f @@ -88,8 +88,8 @@ theorem indOfFunctorLinear letI := linearOfScalarUnit ψ letI := linearOfScalarUnit (indScalarUnit ψ) Functor.Linear ℂ (indOf : C ⥤ Ind C) := by - letI := linearOfScalarUnit ψ - letI := linearOfScalarUnit (indScalarUnit ψ) + let := linearOfScalarUnit ψ + let := linearOfScalarUnit (indScalarUnit ψ) exact ⟨fun f c => indOf_map_scalarSmul ψ c f⟩ end Installed @@ -111,8 +111,8 @@ theorem indOfLinear_of_scalarUnit letI := linearOfScalarUnit ψ letI := linearOfScalarUnit (indScalarUnit ψ) IndOfLinear C := by - letI := linearOfScalarUnit ψ - letI := linearOfScalarUnit (indScalarUnit ψ) + let := linearOfScalarUnit ψ + let := linearOfScalarUnit (indScalarUnit ψ) exact fun _ _ c f => indOf_map_scalarSmul ψ c f end Hypothesis diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchur.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchur.lean index b4b0596921..7e9d344bee 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchur.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchur.lean @@ -372,7 +372,7 @@ lemma dayCoyonedaIso_hom_associator [SmallCategory D] [MonoidalCategory D] (dayCoyonedaUnitElt a (b ⊗ c)) rw [hnatl, whiskerLeft_dayCoyonedaIso_app_unitElt, hnati, dayCoyonedaIso_hom_app_unitElt] - show (α_ a b c).inv ≫ 𝟙 ((a ⊗ b) ⊗ c) = + change (α_ a b c).inv ≫ 𝟙 ((a ⊗ b) ⊗ c) = 𝟙 (a ⊗ (b ⊗ c)) ≫ (α_ a b c).inv rw [Category.id_comp, Category.comp_id] @@ -433,7 +433,7 @@ lemma dayCoyonedaIso_hom_braiding (eta_comp_dayCoyonedaIso_hom b a) exact ConcreteCategory.congr_hom h ((𝟙 b, 𝟙 a) : (b ⟶ b) × (a ⟶ a)) rw [hβ, hnat, hid] - show (𝟙 b ⊗ₘ 𝟙 a) ≫ (β_ b a).hom = (β_ b a).hom ≫ 𝟙 (a ⊗ b) + change (𝟙 b ⊗ₘ 𝟙 a) ≫ (β_ b a).hom = (β_ b a).hom ≫ 𝟙 (a ⊗ b) rw [MonoidalCategory.id_tensorHom_id, Category.id_comp, Category.comp_id] @@ -810,7 +810,7 @@ lemma indOfPowIso_swapTop (X : C) (n : ℕ) : swapTop (indOf.obj X) n ≫ (indOfPowIso X (n + 2)).hom = (indOfPowIso X (n + 2)).hom ≫ indOf.map (swapTop X n) := by - show ((α_ (tensorPow (Ind C) (indOf.obj X) n) (indOf.obj X) + 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) ≫ @@ -839,7 +839,7 @@ lemma indOfPowIso_whiskerRight [SmallCategory C] [MonoidalCategory C] (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 - show (f ▷ indOf.obj X) ≫ + 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) ≫ @@ -897,7 +897,7 @@ theorem indOfPowIso_permMor induction n with | zero => intro σ - show 𝟙 _ ≫ _ = _ ≫ indOf.map (𝟙 _) + change 𝟙 _ ≫ _ = _ ≫ indOf.map (𝟙 _) rw [Category.id_comp, CategoryTheory.Functor.map_id, Category.comp_id] | succ m ih => @@ -926,9 +926,9 @@ 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 - haveI : HasFiniteBiproducts C := + have : HasFiniteBiproducts C := HasFiniteBiproducts.of_hasFiniteCoproducts - haveI : indOf.PreservesZeroMorphisms (C := C) := + have : indOf.PreservesZeroMorphisms (C := C) := Functor.preservesZeroMorphisms_of_map_zero_object ((isZero_indOf (isZero_zero C)).isoZero) constructor diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean index 8dbd3ff3b3..cb9040b71e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean @@ -232,9 +232,9 @@ theorem permAlg_indOf_conj_scalarUnit letI := linearOfScalarUnit (indScalarUnit ψ) permAlg (indOf.obj X) n x ≫ (indOfPowIso X n).hom = (indOfPowIso X n).hom ≫ indOf.map (permAlg X n x) := by - letI := linearOfScalarUnit ψ - letI := linearOfScalarUnit (indScalarUnit ψ) - haveI := indOf_additive (C := C) + 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] @@ -263,8 +263,8 @@ theorem schurKilled_indOf {C : Type v} [SmallCategory C] [MonoidalCategory C] letI := linearOfScalarUnit (indScalarUnit ψ) (SchurKilled P ((indOf : C ⥤ Ind C).obj X) μ ↔ SchurKilled P X μ) := by - letI := linearOfScalarUnit ψ - letI := linearOfScalarUnit (indScalarUnit ψ) + 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 μ)) ≫ @@ -287,7 +287,7 @@ theorem schurKilled_indOf {C : Type v} [SmallCategory C] [MonoidalCategory C] simpa using h1 exact hdown.mpr ((indOf_map_eq_zero_iff _).mp h2) · intro h0 - show permAlg (indOf.obj X) μ.card (P.e μ) = 0 + 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), diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSimple.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSimple.lean index 2657f4ad36..b8caf09ca9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSimple.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSimple.lean @@ -59,16 +59,16 @@ 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 - haveI := indOf_additive (C := C) + have := indOf_additive (C := C) constructor intro U m hm - haveI := 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 - haveI := hiso + 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 @@ -93,12 +93,12 @@ theorem simple_indOf [SmallCategory C] [Abelian C] 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 - haveI : Epi (Ind.yoneda.fullyFaithful.preimage (g ≫ m)) := + have : Epi (Ind.yoneda.fullyFaithful.preimage (g ≫ m)) := epi_of_nonzero_to_simple hfne - haveI : Epi (g ≫ m) := by + have : Epi (g ≫ m) := by rw [← hmap] infer_instance - haveI : Epi m := epi_of_epi g m + have : Epi m := epi_of_epi g m exact isIso_of_mono_of_epi m end Embedding diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplit.lean index 73228492ad..7c1d3b29d2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplit.lean @@ -40,8 +40,8 @@ theorem jtChar_conj (μ : YoungDiagram) (τ π : Equiv.Perm (Fin μ.card)) : refine Finset.sum_congr rfl fun σ _ => ?_ congr 1 by_cases hp : ∀ i, 0 ≤ jtSigned μ σ i - · rw [if_pos hp, if_pos hp, colourChar_conj] - · rw [if_neg hp, if_neg hp] + · 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 @@ -132,7 +132,7 @@ theorem indMult_exists_nat {a b : ℕ} (lam : Shape (a + b)) (Equiv.Perm (Fin a) × Equiv.Perm (Fin b)) : ℂ)) ≠ 0 := by rw [Nat.card_eq_fintype_card] exact_mod_cast Fintype.card_ne_zero - haveI : Invertible ((Nat.card + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplitSection.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplitSection.lean index 710baaf039..6342bb5986 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplitSection.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplitSection.lean @@ -186,12 +186,12 @@ theorem rappel210_indOf 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 - haveI := indOf_additive (C := C) - letI i3 : HasRightDual ((T.map (indOf : C ⥤ Ind C)).X₃) := + have := indOf_additive (C := C) + let i3 : HasRightDual ((T.map (indOf : C ⥤ Ind C)).X₃) := hasRightDualIndOf T.X₃ - letI i3d : HasRightDual (((T.map (indOf : C ⥤ Ind C)).X₃)ᘁ) := + let i3d : HasRightDual (((T.map (indOf : C ⥤ Ind C)).X₃)ᘁ) := hasRightDualIndOf ((T.X₃)ᘁ) - letI i4 : HasRightDual + let i4 : HasRightDual (unitFormMid (T.map (indOf : C ⥤ Ind C))) := { rightDual := (indOf : C ⥤ Ind C).obj ((unitFormMid T)ᘁ) exact := exactPairingOfIso (unitFormMidIndOfIso T) } diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean index ae38e873a4..55df977c91 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean @@ -314,7 +314,7 @@ lemma dayCoyonedaIso_hom_natural_right eta_comp_dayCoyonedaIso_hom] ext X : 2 refine ConcreteCategory.hom_ext _ _ fun fg => ?_ - show fg.1 ⊗ₘ (h ≫ fg.2) = (a ◁ h) ≫ (fg.1 ⊗ₘ fg.2) + 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. -/ @@ -351,7 +351,7 @@ lemma dayCoyonedaIso_hom_natural_left eta_comp_dayCoyonedaIso_hom] ext X : 2 refine ConcreteCategory.hom_ext _ _ fun fg => ?_ - show (f ≫ fg.1) ⊗ₘ fg.2 = (f ▷ b) ≫ (fg.1 ⊗ₘ fg.2) + change (f ≫ fg.1) ⊗ₘ fg.2 = (f ▷ b) ≫ (fg.1 ⊗ₘ fg.2) rw [← tensorHom_id, tensorHom_comp_tensorHom, Category.id_comp] end DayNaturality @@ -628,7 +628,7 @@ def coprodCocone {J : Type v₁} [Category.{v₁} J] {ℬ : Type u₃} [Category ι := { app := fun j => coprod.map (coconeLeg c₁ j) (coconeLeg c₂ j) naturality := fun j k u => by - show coprod.map (D₁.map u) (D₂.map u) ≫ + 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) @@ -646,7 +646,7 @@ def coprodCoconeFst ι := { app := fun j => coprod.inl ≫ coprodLeg s j naturality := fun j k u => by - show D₁.map u ≫ coprod.inl ≫ coprodLeg s k = + 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] } @@ -662,7 +662,7 @@ def coprodCoconeSnd ι := { app := fun j => coprod.inr ≫ coprodLeg s j naturality := fun j k u => by - show D₂.map u ≫ coprod.inr ≫ coprodLeg s k = + 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] } @@ -682,7 +682,7 @@ def isColimitCoprodCocone 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 - show coprod.map (coconeLeg c₁ j) (coconeLeg c₂ 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 @@ -693,21 +693,21 @@ def isColimitCoprodCocone uniq s m hm := by have hm' : ∀ j, coprod.map (coconeLeg c₁ j) (coconeLeg c₂ j) ≫ m = coprodLeg s j := hm - show m = coprod.desc (h₁.desc (coprodCoconeFst s)) + 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 - show coconeLeg c₁ j ≫ coprod.inl ≫ m = + 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 - show coconeLeg c₂ j ≫ coprod.inr ≫ m = + change coconeLeg c₂ j ≫ coprod.inr ≫ m = coconeLeg c₂ j ≫ h₂.desc (coprodCoconeSnd s) rw [hf, ← hm' j, coprod.inr_map_assoc] @@ -732,7 +732,7 @@ lemma preservesColimitsOfShape_coprodPairFunctor (isColimitCoprodCocone (isColimitOfPreserves F hc) (isColimitOfPreserves G hc)) (Cocone.ext (Iso.refl _) fun j => ?_)⟩ - show coprod.map (coconeLeg (F.mapCocone c) 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)) @@ -749,7 +749,7 @@ lemma preservesColimitsOfShape_const_of_isConnected { preserves := fun {c} _ => by refine ⟨IsColimit.ofIsoColimit (isColimitConstCocone J W) (Cocone.ext (Iso.refl _) fun j => ?_)⟩ - show 𝟙 W ≫ 𝟙 W = 𝟙 W + change 𝟙 W ≫ 𝟙 W = 𝟙 W rw [Category.comp_id] } end CoconeTools @@ -776,7 +776,7 @@ lemma isIso_app_of_isIso_indOf [SmallCategory C] infer_instance have hw : ∀ k, IsIso ((Functor.whiskerLeft D γ).app k) := fun k => hbase (A.presentation.F.obj k) - haveI : IsIso (Functor.whiskerLeft D γ) := + have : IsIso (Functor.whiskerLeft D γ) := NatIso.isIso_of_isIso_app _ have hL : IsColimit (L.mapCocone (colimit.cocone D)) := isColimitOfPreserves L (colimit.isColimit D) @@ -882,15 +882,15 @@ lemma isIso_coprodComparison_tensorLeft_indOf₀ (a x y : C) : IsIso (coprodComparison (tensorLeft (indOf.obj a)) (indOf.obj x) (indOf.obj y)) := by - haveI : HasFiniteBiproducts C := + have : HasFiniteBiproducts C := HasFiniteBiproducts.of_hasFiniteCoproducts - haveI : HasBinaryBiproducts C := + have : HasBinaryBiproducts C := hasBinaryBiproducts_of_finite_biproducts C - haveI : PreservesBiproductsOfShape WalkingPair (tensorLeft a) := + have : PreservesBiproductsOfShape WalkingPair (tensorLeft a) := PreservesFiniteBiproducts.preserves - haveI := preservesBinaryBiproducts_of_preservesBiproducts + have := preservesBinaryBiproducts_of_preservesBiproducts (tensorLeft a) - haveI := preservesBinaryCoproducts_of_preservesBinaryBiproducts + have := preservesBinaryCoproducts_of_preservesBinaryBiproducts (tensorLeft a) exact isIso_of_coprod_eq_whiskerLeft_indOf a x y (PreservesColimitPair.iso (tensorLeft a) x y).hom @@ -910,15 +910,15 @@ lemma isIso_coprodComparison_tensorRight_indOf₀ (a x y : C) : IsIso (coprodComparison (tensorRight (indOf.obj a)) (indOf.obj x) (indOf.obj y)) := by - haveI : HasFiniteBiproducts C := + have : HasFiniteBiproducts C := HasFiniteBiproducts.of_hasFiniteCoproducts - haveI : HasBinaryBiproducts C := + have : HasBinaryBiproducts C := hasBinaryBiproducts_of_finite_biproducts C - haveI : PreservesBiproductsOfShape WalkingPair (tensorRight a) := + have : PreservesBiproductsOfShape WalkingPair (tensorRight a) := PreservesFiniteBiproducts.preserves - haveI := preservesBinaryBiproducts_of_preservesBiproducts + have := preservesBinaryBiproducts_of_preservesBiproducts (tensorRight a) - haveI := preservesBinaryCoproducts_of_preservesBinaryBiproducts + have := preservesBinaryCoproducts_of_preservesBinaryBiproducts (tensorRight a) exact isIso_of_coprod_eq_whiskerRight_indOf a x y (PreservesColimitPair.iso (tensorRight a) x y).hom @@ -939,7 +939,7 @@ lemma isIso_coprodComparison_tensorLeft_indOf₁ (Y : Ind C) : IsIso (coprodComparison (tensorLeft (indOf.obj a)) (indOf.obj x) Y) := by - haveI hL : PreservesFilteredColimits + have hL : PreservesFilteredColimits (coprodPairFunctor ((Functor.const (Ind C)).obj (indOf.obj a ⊗ indOf.obj x)) (tensorLeft (indOf.obj a))) := ⟨fun I _ _ => @@ -947,14 +947,14 @@ lemma isIso_coprodComparison_tensorLeft_indOf₁ haveI := preservesColimitsOfShape_const_of_isConnected (𝒜 := Ind C) (J := I) (indOf.obj a ⊗ indOf.obj x) preservesColimitsOfShape_coprodPairFunctor _ _⟩ - haveI hR : PreservesFilteredColimits + have hR : PreservesFilteredColimits (coprodPairFunctor ((Functor.const (Ind C)).obj (indOf.obj x)) (𝟭 (Ind C)) ⋙ tensorLeft (indOf.obj a)) := ⟨fun I _ _ => by - haveI := IsFiltered.isConnected (C := I) - haveI := preservesColimitsOfShape_const_of_isConnected + have := IsFiltered.isConnected (C := I) + have := preservesColimitsOfShape_const_of_isConnected (𝒜 := Ind C) (J := I) (indOf.obj x) - haveI := preservesColimitsOfShape_coprodPairFunctor + have := preservesColimitsOfShape_coprodPairFunctor ((Functor.const (Ind C)).obj (indOf.obj x)) (𝟭 (Ind C)) (J := I) infer_instance⟩ @@ -966,7 +966,7 @@ lemma isIso_coprodComparison_tensorLeft_indOf₁ (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 - show coprod.map (𝟙 (indOf.obj a ⊗ indOf.obj x)) + 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) = @@ -988,7 +988,7 @@ lemma isIso_coprodComparison_tensorRight_indOf₁ (Y : Ind C) : IsIso (coprodComparison (tensorRight (indOf.obj a)) (indOf.obj x) Y) := by - haveI hL : PreservesFilteredColimits + have hL : PreservesFilteredColimits (coprodPairFunctor ((Functor.const (Ind C)).obj (indOf.obj x ⊗ indOf.obj a)) (tensorRight (indOf.obj a))) := ⟨fun I _ _ => @@ -996,14 +996,14 @@ lemma isIso_coprodComparison_tensorRight_indOf₁ haveI := preservesColimitsOfShape_const_of_isConnected (𝒜 := Ind C) (J := I) (indOf.obj x ⊗ indOf.obj a) preservesColimitsOfShape_coprodPairFunctor _ _⟩ - haveI hR : PreservesFilteredColimits + have hR : PreservesFilteredColimits (coprodPairFunctor ((Functor.const (Ind C)).obj (indOf.obj x)) (𝟭 (Ind C)) ⋙ tensorRight (indOf.obj a)) := ⟨fun I _ _ => by - haveI := IsFiltered.isConnected (C := I) - haveI := preservesColimitsOfShape_const_of_isConnected + have := IsFiltered.isConnected (C := I) + have := preservesColimitsOfShape_const_of_isConnected (𝒜 := Ind C) (J := I) (indOf.obj x) - haveI := preservesColimitsOfShape_coprodPairFunctor + have := preservesColimitsOfShape_coprodPairFunctor ((Functor.const (Ind C)).obj (indOf.obj x)) (𝟭 (Ind C)) (J := I) infer_instance⟩ @@ -1015,7 +1015,7 @@ lemma isIso_coprodComparison_tensorRight_indOf₁ ((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 - show coprod.map (𝟙 (indOf.obj x ⊗ indOf.obj a)) + 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) = @@ -1037,7 +1037,7 @@ lemma isIso_coprodComparison_tensorLeft_indOf₂ (a : C) (X Y : Ind C) : IsIso (coprodComparison (tensorLeft (indOf.obj a)) X Y) := by - haveI hL : PreservesFilteredColimits + have hL : PreservesFilteredColimits (coprodPairFunctor (tensorLeft (indOf.obj a)) ((Functor.const (Ind C)).obj (indOf.obj a ⊗ Y))) := ⟨fun I _ _ => @@ -1045,15 +1045,15 @@ lemma isIso_coprodComparison_tensorLeft_indOf₂ haveI := preservesColimitsOfShape_const_of_isConnected (𝒜 := Ind C) (J := I) (indOf.obj a ⊗ Y) preservesColimitsOfShape_coprodPairFunctor _ _⟩ - haveI hR : PreservesFilteredColimits + have hR : PreservesFilteredColimits (coprodPairFunctor (𝟭 (Ind C)) ((Functor.const (Ind C)).obj Y) ⋙ tensorLeft (indOf.obj a)) := ⟨fun I _ _ => by - haveI := IsFiltered.isConnected (C := I) - haveI := preservesColimitsOfShape_const_of_isConnected + have := IsFiltered.isConnected (C := I) + have := preservesColimitsOfShape_const_of_isConnected (𝒜 := Ind C) (J := I) Y - haveI := preservesColimitsOfShape_coprodPairFunctor + have := preservesColimitsOfShape_coprodPairFunctor (𝟭 (Ind C)) ((Functor.const (Ind C)).obj Y) (J := I) infer_instance⟩ let γ : coprodPairFunctor (tensorLeft (indOf.obj a)) @@ -1065,7 +1065,7 @@ lemma isIso_coprodComparison_tensorLeft_indOf₂ (indOf.obj a ◁ (coprod.inl : B ⟶ B ⨿ Y)) (indOf.obj a ◁ (coprod.inr : Y ⟶ B ⨿ Y)) naturality := fun B B' u => by - show coprod.map (indOf.obj a ◁ u) + change coprod.map (indOf.obj a ◁ u) (𝟙 (indOf.obj a ⊗ Y)) ≫ coprod.desc (indOf.obj a ◁ coprod.inl) (indOf.obj a ◁ coprod.inr) = @@ -1086,7 +1086,7 @@ lemma isIso_coprodComparison_tensorRight_indOf₂ (a : C) (X Y : Ind C) : IsIso (coprodComparison (tensorRight (indOf.obj a)) X Y) := by - haveI hL : PreservesFilteredColimits + have hL : PreservesFilteredColimits (coprodPairFunctor (tensorRight (indOf.obj a)) ((Functor.const (Ind C)).obj (Y ⊗ indOf.obj a))) := ⟨fun I _ _ => @@ -1094,15 +1094,15 @@ lemma isIso_coprodComparison_tensorRight_indOf₂ haveI := preservesColimitsOfShape_const_of_isConnected (𝒜 := Ind C) (J := I) (Y ⊗ indOf.obj a) preservesColimitsOfShape_coprodPairFunctor _ _⟩ - haveI hR : PreservesFilteredColimits + have hR : PreservesFilteredColimits (coprodPairFunctor (𝟭 (Ind C)) ((Functor.const (Ind C)).obj Y) ⋙ tensorRight (indOf.obj a)) := ⟨fun I _ _ => by - haveI := IsFiltered.isConnected (C := I) - haveI := preservesColimitsOfShape_const_of_isConnected + have := IsFiltered.isConnected (C := I) + have := preservesColimitsOfShape_const_of_isConnected (𝒜 := Ind C) (J := I) Y - haveI := preservesColimitsOfShape_coprodPairFunctor + have := preservesColimitsOfShape_coprodPairFunctor (𝟭 (Ind C)) ((Functor.const (Ind C)).obj Y) (J := I) infer_instance⟩ let γ : coprodPairFunctor (tensorRight (indOf.obj a)) @@ -1114,7 +1114,7 @@ lemma isIso_coprodComparison_tensorRight_indOf₂ ((coprod.inl : B ⟶ B ⨿ Y) ▷ indOf.obj a) ((coprod.inr : Y ⟶ B ⨿ Y) ▷ indOf.obj a) naturality := fun B B' u => by - show coprod.map (u ▷ indOf.obj a) + change coprod.map (u ▷ indOf.obj a) (𝟙 (Y ⊗ indOf.obj a)) ≫ coprod.desc (coprod.inl ▷ indOf.obj a) (coprod.inr ▷ indOf.obj a) = @@ -1135,7 +1135,7 @@ lemma isIso_coprodComparison_tensorLeft [HasFiniteColimits C] [MonoidalPreadditive C] (A X Y : Ind C) : IsIso (coprodComparison (tensorLeft A) X Y) := by - haveI hL : PreservesFilteredColimits + have hL : PreservesFilteredColimits (coprodPairFunctor (tensorRight X) (tensorRight Y)) := ⟨fun I _ _ => preservesColimitsOfShape_coprodPairFunctor _ _⟩ let γ : coprodPairFunctor (tensorRight X) (tensorRight Y) ⟶ @@ -1144,7 +1144,7 @@ lemma isIso_coprodComparison_tensorLeft (B ◁ (coprod.inl : X ⟶ X ⨿ Y)) (B ◁ (coprod.inr : Y ⟶ X ⨿ Y)) naturality := fun B B' u => by - show coprod.map (u ▷ X) (u ▷ Y) ≫ + 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)) @@ -1161,7 +1161,7 @@ lemma isIso_coprodComparison_tensorRight [HasFiniteColimits C] [MonoidalPreadditive C] (A X Y : Ind C) : IsIso (coprodComparison (tensorRight A) X Y) := by - haveI hL : PreservesFilteredColimits + have hL : PreservesFilteredColimits (coprodPairFunctor (tensorLeft X) (tensorLeft Y)) := ⟨fun I _ _ => preservesColimitsOfShape_coprodPairFunctor _ _⟩ let γ : coprodPairFunctor (tensorLeft X) (tensorLeft Y) ⟶ @@ -1170,7 +1170,7 @@ lemma isIso_coprodComparison_tensorRight ((coprod.inl : X ⟶ X ⨿ Y) ▷ B) ((coprod.inr : Y ⟶ X ⨿ Y) ▷ B) naturality := fun B B' u => by - show coprod.map (X ◁ u) (Y ◁ u) ≫ + 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) @@ -1219,7 +1219,7 @@ lemma isZero_tensor_left_ind [HasFiniteColimits C] [MonoidalPreadditive C] (A : Ind C) {Z : Ind C} (hZ : IsZero Z) : IsZero (A ⊗ Z) := by - haveI : HasFiniteBiproducts C := + 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 @@ -1250,7 +1250,7 @@ lemma isZero_tensor_right_ind [HasFiniteColimits C] [MonoidalPreadditive C] (A : Ind C) {Z : Ind C} (hZ : IsZero Z) : IsZero (Z ⊗ A) := by - haveI : HasFiniteBiproducts C := + 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 @@ -1299,9 +1299,9 @@ lemma preservesBinaryCoproducts_tensorLeft_ind PreservesColimitsOfShape (Discrete WalkingPair) (tensorLeft A) where preservesColimit {K} := by - haveI := isIso_coprodComparison_tensorLeft A + have := isIso_coprodComparison_tensorLeft A (K.obj ⟨WalkingPair.left⟩) (K.obj ⟨WalkingPair.right⟩) - haveI := PreservesColimitPair.of_iso_coprod_comparison + have := PreservesColimitPair.of_iso_coprod_comparison (tensorLeft A) (K.obj ⟨WalkingPair.left⟩) (K.obj ⟨WalkingPair.right⟩) exact preservesColimit_of_iso_diagram _ (diagramIsoPair K).symm @@ -1314,9 +1314,9 @@ lemma preservesBinaryCoproducts_tensorRight_ind PreservesColimitsOfShape (Discrete WalkingPair) (tensorRight A) where preservesColimit {K} := by - haveI := isIso_coprodComparison_tensorRight A + have := isIso_coprodComparison_tensorRight A (K.obj ⟨WalkingPair.left⟩) (K.obj ⟨WalkingPair.right⟩) - haveI := PreservesColimitPair.of_iso_coprod_comparison + have := PreservesColimitPair.of_iso_coprod_comparison (tensorRight A) (K.obj ⟨WalkingPair.left⟩) (K.obj ⟨WalkingPair.right⟩) exact preservesColimit_of_iso_diagram _ (diagramIsoPair K).symm @@ -1327,11 +1327,11 @@ instance tensorLeft_ind_additive [HasFiniteColimits C] [MonoidalPreadditive C] (A : Ind C) : (tensorLeft A).Additive := by - haveI : HasBinaryBiproducts (Ind C) := + have : HasBinaryBiproducts (Ind C) := hasBinaryBiproducts_of_finite_biproducts (Ind C) - haveI := preservesZeroMorphisms_tensorLeft_ind A - haveI := preservesBinaryCoproducts_tensorLeft_ind A - haveI := preservesBinaryBiproducts_of_preservesBinaryCoproducts + have := preservesZeroMorphisms_tensorLeft_ind A + have := preservesBinaryCoproducts_tensorLeft_ind A + have := preservesBinaryBiproducts_of_preservesBinaryCoproducts (tensorLeft A) exact Functor.additive_of_preservesBinaryBiproducts _ @@ -1341,11 +1341,11 @@ instance tensorRight_ind_additive [HasFiniteColimits C] [MonoidalPreadditive C] (A : Ind C) : (tensorRight A).Additive := by - haveI : HasBinaryBiproducts (Ind C) := + have : HasBinaryBiproducts (Ind C) := hasBinaryBiproducts_of_finite_biproducts (Ind C) - haveI := preservesZeroMorphisms_tensorRight_ind A - haveI := preservesBinaryCoproducts_tensorRight_ind A - haveI := preservesBinaryBiproducts_of_preservesBinaryCoproducts + have := preservesZeroMorphisms_tensorRight_ind A + have := preservesBinaryCoproducts_tensorRight_ind A + have := preservesBinaryBiproducts_of_preservesBinaryCoproducts (tensorRight A) exact Functor.additive_of_preservesBinaryBiproducts _ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitDatum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitDatum.lean index 3971039002..b579418204 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitDatum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitDatum.lean @@ -123,7 +123,7 @@ theorem unitBaseDatum_zigzag refine Eq.trans (eq_whisker (congrArg (fun t => X ◁ t) h2) _) ?_ exact whisker_eq _ (actRight_unitBase X) - show (λ_ X).inv ≫ + change (λ_ X).inv ≫ ((η[𝟙_ D] ≫ (unitBaseDatum X Y).copair) ▷ X) ≫ zigContract (𝟙_ D) (unitBaseDatum X Y).pair (unitBaseDatum X Y).pair_linear = 𝟙 X @@ -164,7 +164,7 @@ theorem unitBaseDatum_zigzag refine Eq.trans (eq_whisker (congrArg (fun t => t ▷ Y) h2) _) ?_ exact whisker_eq _ (actLeft_unitBase Y) - show (ρ_ Y).inv ≫ + change (ρ_ Y).inv ≫ (Y ◁ (η[𝟙_ D] ≫ (unitBaseDatum X Y).copair)) ≫ zagContract (𝟙_ D) (unitBaseDatum X Y).pair (unitBaseDatum X Y).pair_linear = 𝟙 Y diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean index bb7261f2e6..ab814ca98f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean @@ -290,7 +290,7 @@ theorem chainMul_actLeft (A ◁ chainMul A M M' m n) ≫ modTensorAct A (symPowMod A M'.X (m + 1 + n)) (symPowMod A M.X (m + 1 + n)) := by - show (modTensorAct A (symPowMod A M'.X m) (symPowMod A M.X m) ▷ + 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) ≫ @@ -338,7 +338,7 @@ theorem chainMul2_actLeft (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 - show (modTensorAct A (symPowMod A M'.X p) (symPowMod A M.X q) ▷ + 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) ≫ @@ -394,7 +394,7 @@ theorem chainMul2_actMid (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 - show (modTensor A (symPowMod A M'.X p) (symPowMod A M.X q) ◁ + 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) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KernelPow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KernelPow.lean index e629b688d5..8f58fd9f15 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KernelPow.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KernelPow.lean @@ -146,7 +146,7 @@ theorem wordPow_append_succ [Category.{v} A] [MonoidalCategory A] 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 - show wordPow U V (a + b) (wordAppend wa wb ∘ Fin.castSucc) ⊗ + 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] @@ -259,7 +259,7 @@ theorem wordMap_append rw [wordMap_congr f g (wordAppend_zero wa wb), eqToHom_trans_assoc] exact word_map_cast f g wa _ - show ((ρ_ (wordPow U V a wa)).hom ≫ + 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)) ≫ @@ -367,7 +367,7 @@ theorem wordPow_const_false [Category.{v} A] [MonoidalCategory A] induction n with | zero => rfl | succ n ih => - show wordPow X Y n (fun _ => false) ⊗ Y = tensorPow A Y n ⊗ Y + 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 @@ -392,7 +392,7 @@ theorem wordMap_const_false | zero => exact (Category.id_comp _).symm | succ n ih => - show wordMap f g n (fun _ => false) ⊗ₘ g = _ + change wordMap f g n (fun _ => false) ⊗ₘ g = _ rw [ih] exact eqToHom_tensor_pull (wordPow_const_false U V n) _ _ @@ -536,7 +536,7 @@ theorem kernelSubobject_comp_le_of_cover [Category.{v} A] [Abelian A] Epi q' ∧ q' ≫ (imageSubobject (b ≫ u)).arrow = b ≫ u := ⟨factorThruImageSubobject (b ≫ u), inferInstance, imageSubobject_arrow_comp (b ≫ u)⟩ - haveI := hq_epi + have := hq_epi refine kernelSubobject_le_of_factors (factors_of_epi_comp _ (pullback.fst t q) (kernel.ι (u ≫ v)) ?_) @@ -583,7 +583,7 @@ 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 - haveI : PreservesColimitsOfSize.{0, 0} (tensorRight W) := + have : PreservesColimitsOfSize.{0, 0} (tensorRight W) := preservesSmallestColimits_of_preservesColimits _ exact (tensorRight W).map_epi p @@ -592,7 +592,7 @@ 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 - haveI : PreservesColimitsOfSize.{0, 0} (tensorLeft W) := + have : PreservesColimitsOfSize.{0, 0} (tensorLeft W) := preservesSmallestColimits_of_preservesColimits _ exact (tensorLeft W).map_epi p @@ -610,7 +610,7 @@ private theorem exists_kernel_ι_whiskerRight (W : A) : ∃ e : kernel (p ▷ W) ⟶ kernel p ⊗ W, kernel.ι (p ▷ W) = e ≫ (kernel.ι p ▷ W) := by - haveI : PreservesLimitsOfSize.{0, 0} (tensorRight W) := + have : PreservesLimitsOfSize.{0, 0} (tensorRight W) := preservesSmallestLimits_of_preservesLimits _ exact ⟨(PreservesKernel.iso (tensorRight W) p).inv, (PreservesKernel.iso_inv_ι (tensorRight W) p).symm⟩ @@ -625,7 +625,7 @@ private theorem exists_kernel_ι_whiskerLeft (p : X ⟶ Y) : ∃ e : kernel (W ◁ p) ⟶ W ⊗ kernel p, kernel.ι (W ◁ p) = e ≫ (W ◁ kernel.ι p) := by - haveI : PreservesLimitsOfSize.{0, 0} (tensorLeft W) := + have : PreservesLimitsOfSize.{0, 0} (tensorLeft W) := preservesSmallestLimits_of_preservesLimits _ exact ⟨(PreservesKernel.iso (tensorLeft W) p).inv, (PreservesKernel.iso_inv_ι (tensorLeft W) p).symm⟩ @@ -673,7 +673,7 @@ theorem factors_imageSubobject_whiskerRight {f : X ⟶ B} {c : C' ⟶ B} (h : (imageSubobject c).Factors f) (W : A) : (imageSubobject (c ▷ W)).Factors (f ▷ W) := by - haveI : Epi (factorThruImageSubobject c ▷ W) := + have : Epi (factorThruImageSubobject c ▷ W) := epi_whiskerRight_of_epi (factorThruImageSubobject c) W have harrow : (imageSubobject (c ▷ W)).Factors ((imageSubobject c).arrow ▷ W) := by @@ -700,7 +700,7 @@ theorem factors_imageSubobject_whiskerLeft {f : X ⟶ B} {c : C' ⟶ B} (h : (imageSubobject c).Factors f) (W : A) : (imageSubobject (W ◁ c)).Factors (W ◁ f) := by - haveI : Epi (W ◁ factorThruImageSubobject c) := + have : Epi (W ◁ factorThruImageSubobject c) := epi_whiskerLeft_of_epi W (factorThruImageSubobject c) have harrow : (imageSubobject (W ◁ c)).Factors (W ◁ (imageSubobject c).arrow) := by @@ -739,7 +739,7 @@ theorem kernelSubobject_tensorHom_le imageSubobject (Z₁ ◁ kernel.ι p₂) := by have hv : kernelSubobject (W₁ ◁ p₂) ≤ imageSubobject ((Z₁ ◁ kernel.ι p₂) ≫ (p₁ ▷ Z₂)) := by - haveI : Epi (p₁ ▷ kernel p₂) := epi_whiskerRight_of_epi p₁ _ + 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₂) _ ?_)) @@ -960,7 +960,7 @@ theorem kernelSubobject_tensorPowMap_le_cover rw [h] exact Subobject.factors_zero | succ m ih => - haveI : Epi (tensorPowMap π m) := tensorPowMap_epi π m + have : Epi (tensorPowMap π m) := tensorPowMap_epi π m refine le_trans (kernelSubobject_tensorHom_le (tensorPowMap π m) π) (sup_le ?_ ?_) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaClose.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaClose.lean index 56446d5d1d..6e67cf4ef3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaClose.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaClose.lean @@ -64,7 +64,7 @@ theorem keyLemmaData_ind (d : ModDualityDatum B N N') : KeyLemmaDataStatement B d := by intro hz _ hS - letI := chainBGrMonObj B N N' d + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean index d6de490fe9..6a147efa43 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean @@ -81,13 +81,13 @@ theorem extProd_single {n : ℕ} (σ τ : Equiv.Perm (Fin n)) (MonoidAlgebra.single σ c) = MonoidAlgebra.single ((σ, 1) : Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) c := by - show MonoidAlgebra.mapDomain _ (MonoidAlgebra.single σ c) = _ + 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 - show MonoidAlgebra.mapDomain _ (MonoidAlgebra.single τ d) = _ + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single τ d) = _ exact MonoidAlgebra.mapDomain_single unfold extProd rw [hL, hR, MonoidAlgebra.single_mul_single] @@ -109,7 +109,7 @@ theorem extImages_comm {n : ℕ} (x y : SymGroupAlgebra n) : MonoidAlgebra.single ((σ, 1) : Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) (1 : ℂ) := by - show MonoidAlgebra.mapDomain _ + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single σ 1) = _ exact MonoidAlgebra.mapDomain_single have hR : MonoidAlgebra.mapDomainAlgHom ℂ ℂ (extSndHom n) @@ -117,7 +117,7 @@ theorem extImages_comm {n : ℕ} (x y : SymGroupAlgebra n) : MonoidAlgebra.single ((1, τ) : Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) (1 : ℂ) := by - show MonoidAlgebra.mapDomain _ + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single τ 1) = _ exact MonoidAlgebra.mapDomain_single simp only [MonoidAlgebra.of_apply] @@ -211,8 +211,8 @@ theorem extProd_apply_pair {n : ℕ} (x y : SymGroupAlgebra n) intro he exact hcase ⟨congrArg Prod.fst he, congrArg Prod.snd he⟩ rcases not_and_or.mp hcase with hσ | hτ - · simp [MonoidAlgebra.coeff_single_apply, hne, hσ] - · simp [MonoidAlgebra.coeff_single_apply, hne, 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] @@ -233,7 +233,7 @@ theorem extProd_shape_e_coeff_conj (P : SchurPackage.{u}) {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 - show (extProd (Shape.e P μ) (Shape.e P ν)).coeff + 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, @@ -277,14 +277,14 @@ theorem diagHom_injective (n : ℕ) : /-- 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 - show Finsupp.mapDomain (diagHom n) x.coeff (σ, σ) = x.coeff σ + 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 - show Finsupp.mapDomain (diagHom n) x.coeff p = 0 + change Finsupp.mapDomain (diagHom n) x.coeff p = 0 refine Finsupp.mapDomain_of_notMem_range x.coeff p ?_ rintro ⟨σ, hσ⟩ rw [← hσ] at h @@ -301,7 +301,7 @@ theorem extProd_mul_diagEmbed_apply_one (P : SchurPackage.{u}) ((n.factorial : ℂ) * (n.factorial : ℂ)) * kronMult lam μ ν := by classical - show (extProd (Shape.e P μ) (Shape.e P ν) * + change (extProd (Shape.e P μ) (Shape.e P ν) * diagEmbed (Shape.e P lam)).coeff 1 = _ rw [mul_apply_one] have hoff : ∀ p ∈ (Finset.univ : diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/LambdaCoend.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/LambdaCoend.lean index 0eacf10965..229ac16ff8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/LambdaCoend.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/LambdaCoend.lean @@ -138,7 +138,7 @@ def lambdaDiagramMap app X := { app := fun Y => η.app ((unop X)ᘁ) ⊗ₘ τ.app Y naturality := fun Y Y' g => by - show α.obj ((unop X)ᘁ) ◁ β.map g ≫ + change α.obj ((unop X)ᘁ) ◁ β.map g ≫ (η.app ((unop X)ᘁ) ⊗ₘ τ.app Y') = (η.app ((unop X)ᘁ) ⊗ₘ τ.app Y) ≫ α'.obj ((unop X)ᘁ) ◁ β'.map g @@ -148,7 +148,7 @@ def lambdaDiagramMap ← MonoidalCategory.whiskerLeft_comp, τ.naturality] } naturality f f' g := by ext Y - show α.map ((g.unop)ᘁ) ▷ β.obj Y ≫ + change α.map ((g.unop)ᘁ) ▷ β.obj Y ≫ (η.app ((unop f')ᘁ) ⊗ₘ τ.app Y) = (η.app ((unop f)ᘁ) ⊗ₘ τ.app Y) ≫ α'.map ((g.unop)ᘁ) ▷ β'.obj Y @@ -266,7 +266,7 @@ theorem coend_hom_ext_of_preserves colimit.ι (multispanIndexCoend F).multispan (.left a) := colimit.w _ _ have hf := h ((multispanShapeCoend J).fst a) - show G.map + change G.map (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ f = G.map @@ -302,7 +302,7 @@ theorem tensorLeft_coend_hom_ext colimit.ι (multispanIndexCoend F).multispan (.left a) := colimit.w _ _ have hf := h ((multispanShapeCoend J).fst a) - show (tensorLeft W).map + change (tensorLeft W).map (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ f = (tensorLeft W).map @@ -334,7 +334,7 @@ theorem tensorRight_coend_hom_ext colimit.ι (multispanIndexCoend F).multispan (.left a) := colimit.w _ _ have hf := h ((multispanShapeCoend J).fst a) - show (tensorRight W).map + change (tensorRight W).map (colimit.ι (multispanIndexCoend F).multispan (.left a)) ≫ f = (tensorRight W).map @@ -825,7 +825,7 @@ theorem unitTensorDualIso_inv_comp_evaluation 𝟙 _ ⊗≫ (Yᘁ : A) ◁ (unitRigidEvaluation (A := A) ▷ Y) ⊗≫ ε_ Y (Yᘁ) := by - letI pt : ExactPairing (𝟙_ A ⊗ Y) + let pt : ExactPairing (𝟙_ A ⊗ Y) ((Yᘁ : A) ⊗ unitRigidDual) := @ExactPairing.tensor A _ _ (𝟙_ A) Y (unitRigidDual (A := A)) (Yᘁ) (@HasRightDual.exact A _ _ (𝟙_ A) @@ -859,7 +859,7 @@ theorem tensorUnitDualIso_inv_comp_evaluation 𝟙 _ ⊗≫ (unitRigidDual (A := A)) ◁ (ε_ Y (Yᘁ) ▷ (𝟙_ A)) ⊗≫ unitRigidEvaluation (A := A) := by - letI pt : ExactPairing (Y ⊗ 𝟙_ A) + let pt : ExactPairing (Y ⊗ 𝟙_ A) ((unitRigidDual (A := A)) ⊗ (Yᘁ : A)) := @ExactPairing.tensor A _ _ Y (𝟙_ A) (Yᘁ) (unitRigidDual (A := A)) inferInstance @@ -1184,7 +1184,7 @@ theorem lambdaMulStage_unit_left rw [tensor_left_unitality] simp only [Category.assoc, tensorHom_comp_tensorHom, Iso.hom_inv_id, id_tensorHom_id, Category.comp_id] - show ((λ_ (𝟙_ D)).inv ▷ (α.obj (Yᘁ) ⊗ β.obj Y)) ≫ + change ((λ_ (𝟙_ D)).inv ▷ (α.obj (Yᘁ) ⊗ β.obj Y)) ≫ ((((ε α ≫ α.map unitRightDualIso.inv) ⊗ₘ ε β)) ▷ (α.obj (Yᘁ) ⊗ β.obj Y)) ≫ (tensorμ (α.obj (unitRigidDual (A := A))) (β.obj (𝟙_ A)) @@ -1313,7 +1313,7 @@ theorem lambdaMulLeft_dinat lambdaMulLeft α β X' := by refine tensorLeft_coend_hom_ext (lambdaDiagram α β) (α.obj (X'ᘁ) ⊗ β.obj X) (fun Y => ?_) - show ((α.obj (X'ᘁ) ⊗ β.obj X) ◁ lambdaStage α β Y) ≫ + change ((α.obj (X'ᘁ) ⊗ β.obj X) ◁ lambdaStage α β Y) ≫ ((α.map (fᘁ) ▷ β.obj X) ▷ lambdaObj α β) ≫ lambdaMulLeft α β X = ((α.obj (X'ᘁ) ⊗ β.obj X) ◁ lambdaStage α β Y) ≫ @@ -1398,12 +1398,12 @@ theorem lambdaMul_unit_left (λ_ (lambdaObj α β)).hom := by refine tensorLeft_coend_hom_ext (lambdaDiagram α β) (𝟙_ D) (fun Y => ?_) - show (𝟙_ D ◁ lambdaStage α β Y) ≫ + change (𝟙_ D ◁ lambdaStage α β Y) ≫ (lambdaUnit α β ▷ lambdaObj α β) ≫ lambdaMul α β = (𝟙_ D ◁ lambdaStage α β Y) ≫ (λ_ (lambdaObj α β)).hom erw [lambdaUnit, comp_whiskerRight, comp_whiskerRight] simp only [Category.assoc] - show (𝟙_ D ◁ lambdaStage α β Y) ≫ + change (𝟙_ D ◁ lambdaStage α β Y) ≫ ((λ_ (𝟙_ D)).inv ▷ lambdaObj α β) ≫ (((ε α ≫ α.map unitRightDualIso.inv) ⊗ₘ ε β) ▷ lambdaObj α β) ≫ @@ -1437,7 +1437,7 @@ theorem lambdaMulStage_unit_right rw [tensor_right_unitality] simp only [Category.assoc, tensorHom_comp_tensorHom, Iso.hom_inv_id, id_tensorHom_id, Category.comp_id] - show ((α.obj (Yᘁ) ⊗ β.obj Y) ◁ (λ_ (𝟙_ D)).inv) ≫ + change ((α.obj (Yᘁ) ⊗ β.obj Y) ◁ (λ_ (𝟙_ D)).inv) ≫ ((α.obj (Yᘁ) ⊗ β.obj Y) ◁ ((ε α ≫ α.map unitRightDualIso.inv) ⊗ₘ ε β)) ≫ (tensorμ (α.obj (Yᘁ)) (β.obj Y) @@ -1490,7 +1490,7 @@ theorem lambdaMul_unit_right (ρ_ (lambdaObj α β)).hom := by refine tensorRight_coend_hom_ext (lambdaDiagram α β) (𝟙_ D) (fun X => ?_) - show (lambdaStage α β X ▷ 𝟙_ D) ≫ + change (lambdaStage α β X ▷ 𝟙_ D) ≫ (lambdaObj α β ◁ lambdaUnit α β) ≫ lambdaMul α β = (lambdaStage α β X ▷ 𝟙_ D) ≫ (ρ_ (lambdaObj α β)).hom rw [← whisker_exchange_assoc] @@ -1533,7 +1533,7 @@ theorem lambda_triple_hom_ext refine coend_hom_ext_of_preserves (lambdaDiagram α β) (tensorLeft (α.obj (Xᘁ) ⊗ β.obj X) ⋙ tensorRight (α.obj (W'ᘁ) ⊗ β.obj W')) (fun Y => ?_) - show (((α.obj (Xᘁ) ⊗ β.obj X) ◁ lambdaStage α β Y) ▷ + change (((α.obj (Xᘁ) ⊗ β.obj X) ◁ lambdaStage α β Y) ▷ (α.obj (W'ᘁ) ⊗ β.obj W')) ≫ ((lambdaStage α β X ▷ lambdaObj α β) ▷ (α.obj (W'ᘁ) ⊗ β.obj W')) ≫ @@ -1642,7 +1642,7 @@ theorem lambda_pair_hom_ext (lambdaObj α β) (fun X => ?_) refine tensorLeft_coend_hom_ext (lambdaDiagram α β) (α.obj (Xᘁ) ⊗ β.obj X) (fun Y => ?_) - show ((α.obj (Xᘁ) ⊗ β.obj X) ◁ lambdaStage α β Y) ≫ + change ((α.obj (Xᘁ) ⊗ β.obj X) ◁ lambdaStage α β Y) ≫ ((lambdaStage α β X ▷ lambdaObj α β) ≫ f) = ((α.obj (Xᘁ) ⊗ β.obj X) ◁ lambdaStage α β Y) ≫ ((lambdaStage α β X ▷ lambdaObj α β) ≫ g) @@ -1785,8 +1785,7 @@ theorem lambdaMul_comm /-- **The Λ algebra is commutative** over symmetric data with braided functors (Deligne 3.7–3.8 in full). -/ -@[implicit_reducible] -noncomputable def lambdaIsCommMonObj +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) @@ -1809,7 +1808,7 @@ noncomputable def lambdaIsCommMonObj tensorLeft W) (tensorRight W')] : letI : MonObj (lambdaObj α β) := lambdaMonObj α β IsCommMonObj (lambdaObj α β) := by - letI : MonObj (lambdaObj α β) := lambdaMonObj α β + let : MonObj (lambdaObj α β) := lambdaMonObj α β exact ⟨lambdaMul_comm α β⟩ end Commutativity diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean index b4633284ab..bf97babbda 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean @@ -209,11 +209,11 @@ noncomputable def superLetters (r s : ℕ) : cases k with | inl i => apply SuperVect.hom_ext - · show (LinearMap.proj (R := ℂ) (φ := fun _ : Fin r => ℂ) + · change (LinearMap.proj (R := ℂ) (φ := fun _ : Fin r => ℂ) i).comp (LinearMap.single ℂ (fun _ => ℂ) i) = LinearMap.id refine LinearMap.ext fun z => ?_ - show Pi.single (M := fun _ : Fin r => ℂ) i z i = 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) _ _ @@ -221,7 +221,7 @@ noncomputable def superLetters (r s : ℕ) : apply SuperVect.hom_ext · refine LinearMap.ext fun z => ?_ exact Subsingleton.elim (α := Fin 0 → ℂ) _ _ - · show (LinearMap.pi fun _ : Fin 1 => + · change (LinearMap.pi fun _ : Fin 1 => LinearMap.proj (R := ℂ) (φ := fun _ : Fin s => ℂ) j).comp ((LinearMap.single ℂ (fun _ => ℂ) j).comp @@ -229,7 +229,7 @@ noncomputable def superLetters (r s : ℕ) : = LinearMap.id refine LinearMap.ext fun v => ?_ funext i - show Pi.single (M := fun _ : Fin s => ℂ) j (v 0) j = v 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 @@ -237,10 +237,10 @@ noncomputable def superLetters (r s : ℕ) : cases k' with | inl i' => apply SuperVect.hom_ext - · show (LinearMap.proj (R := ℂ) (φ := fun _ : Fin r => ℂ) + · change (LinearMap.proj (R := ℂ) (φ := fun _ : Fin r => ℂ) i').comp (LinearMap.single ℂ (fun _ => ℂ) i) = 0 refine LinearMap.ext fun z => ?_ - show Pi.single (M := fun _ : Fin r => ℂ) i z i' = 0 + 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 => ?_ @@ -250,7 +250,7 @@ noncomputable def superLetters (r s : ℕ) : · refine LinearMap.ext fun z => ?_ exact Subsingleton.elim (α := Fin 0 → ℂ) _ _ · refine LinearMap.ext fun z => ?_ - show (LinearMap.pi fun _ : Fin 1 => + change (LinearMap.pi fun _ : Fin 1 => LinearMap.proj (R := ℂ) (φ := fun _ : Fin s => ℂ) j') ((0 : PUnit →ₗ[ℂ] (Fin s → ℂ)) z) = 0 @@ -260,7 +260,7 @@ noncomputable def superLetters (r s : ℕ) : | inl i' => apply SuperVect.hom_ext · refine LinearMap.ext fun z => ?_ - show (LinearMap.proj (R := ℂ) + change (LinearMap.proj (R := ℂ) (φ := fun _ : Fin r => ℂ) i') ((0 : (Fin 0 → ℂ) →ₗ[ℂ] (Fin r → ℂ)) z) = 0 rfl @@ -270,7 +270,7 @@ noncomputable def superLetters (r s : ℕ) : apply SuperVect.hom_ext · refine LinearMap.ext fun z => ?_ exact Subsingleton.elim (α := Fin 0 → ℂ) _ _ - · show (LinearMap.pi fun _ : Fin 1 => + · change (LinearMap.pi fun _ : Fin 1 => LinearMap.proj (R := ℂ) (φ := fun _ : Fin s => ℂ) j').comp ((LinearMap.single ℂ (fun _ => ℂ) j).comp @@ -278,7 +278,7 @@ noncomputable def superLetters (r s : ℕ) : (φ := fun _ : Fin 1 => ℂ) 0)) = 0 refine LinearMap.ext fun v => ?_ funext i - show Pi.single (M := fun _ : Fin s => ℂ) j (v 0) j' = 0 + 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 := superSum_total r s diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhisker.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhisker.lean index fa84d54206..992e563346 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhisker.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhisker.lean @@ -66,7 +66,7 @@ theorem colourSum_eq_zero_whisker rw [MonoidalCategory.whiskerLeft_comp, MonoidalCategory.whiskerLeft_comp, hx, Limits.zero_comp, Limits.comp_zero] - rw [S.nIn_permAlg_nOut hβ x c d, dif_pos hpop, + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedConc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedConc.lean index 3620d7a46c..9307c99089 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedConc.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedConc.lean @@ -109,19 +109,19 @@ theorem blockEmbed_one_succ (σ : Equiv.Perm (Fin a)) : refine Equiv.ext fun x => ?_ induction x using Fin.addCases with | left i => - show blockEmbed σ 1 (Fin.castAdd (b + 1) 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 => - show blockEmbed σ 1 (Fin.natAdd a (Fin.last b)) = + change blockEmbed σ 1 (Fin.natAdd a (Fin.last b)) = extPerm (blockEmbed σ 1) (Fin.last (a + b)) rw [blockEmbed_natAdd, extPerm_last] rfl | cast j => - show blockEmbed σ 1 (Fin.natAdd a (Fin.castSucc 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 @@ -131,7 +131,7 @@ 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 - show blockEmbed (a := a) (b := b + 1) 1 τ + change blockEmbed (a := a) (b := b + 1) 1 τ (Fin.natAdd a (Fin.last b)) = Fin.natAdd a (topImage τ) rw [blockEmbed_natAdd] @@ -175,7 +175,7 @@ theorem restPerm_blockEmbed (τ : Equiv.Perm (Fin (b + 1))) : Fin.lt_def.mpr (show (i : ℕ) < a + ((topImage τ) : ℕ) by have := i.isLt omega) - show (Fin.natAdd a (topImage τ)).succAbove + 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) @@ -183,7 +183,7 @@ theorem restPerm_blockEmbed (τ : Equiv.Perm (Fin (b + 1))) : Fin.succAbove_of_castSucc_lt _ _ hlt] rfl | right i => - show (Fin.natAdd a (topImage τ)).succAbove + change (Fin.natAdd a (topImage τ)).succAbove (blockEmbed (1 : Equiv.Perm (Fin a)) (restPerm τ) (Fin.natAdd a i)) = blockEmbed (1 : Equiv.Perm (Fin a)) τ @@ -419,7 +419,7 @@ theorem tensorPowConcat_permMor_snd have harith : a + b - ((Fin.natAdd a (topImage τ) : Fin (a + b + 1)) : ℕ) = b - ((topImage τ : Fin (b + 1)) : ℕ) := by - show a + b - (a + ((topImage τ : Fin (b + 1)) : ℕ)) = _ + change a + b - (a + ((topImage τ : Fin (b + 1)) : ℕ)) = _ omega rw [harith] at hs have hs' : permMor X (a + (b + 1)) @@ -500,12 +500,12 @@ theorem blockAlgEmbed_single {a b : ℕ} (σ : Equiv.Perm (Fin a)) have hL : MonoidAlgebra.mapDomainAlgHom ℂ ℂ (blockEmbedFstHom a b) (MonoidAlgebra.single σ c) = MonoidAlgebra.single (blockEmbed σ 1) c := by - show MonoidAlgebra.mapDomain _ (MonoidAlgebra.single σ c) = _ + 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 - show MonoidAlgebra.mapDomain _ (MonoidAlgebra.single τ d) = _ + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single τ d) = _ exact MonoidAlgebra.mapDomain_single unfold blockAlgEmbed rw [hL, hR, MonoidAlgebra.single_mul_single, ← blockEmbed_decompose] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedDiag.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedDiag.lean index 1c731bebbd..bea36fe24f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedDiag.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedDiag.lean @@ -334,11 +334,11 @@ noncomputable def diagPermHom where toFun σ := permMor X n σ ⊗ₘ permMor Y n σ map_one' := by - show permMor X n 1 ⊗ₘ permMor Y n 1 = + 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 - show permMor X n (σ * τ) ⊗ₘ permMor Y n (σ * τ) = + change permMor X n (σ * τ) ⊗ₘ permMor Y n (σ * τ) = (permMor X n τ ⊗ₘ permMor Y n τ) ≫ (permMor X n σ ⊗ₘ permMor Y n σ) rw [permMor_mul, permMor_mul, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAbelian.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAbelian.lean index e2e81ba1bb..00582b608c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAbelian.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAbelian.lean @@ -267,7 +267,7 @@ theorem modBinaryBicone_total + (modBinaryBicone A M N).snd ≫ (modBinaryBicone A M N).inr = 𝟙 (modBinaryBicone A M N).pt := by refine Mod.hom_ext _ _ ?_ - show biprod.fst ≫ biprod.inl + biprod.snd ≫ biprod.inr + change biprod.fst ≫ biprod.inl + biprod.snd ≫ biprod.inr = 𝟙 (M.X ⊞ N.X) exact biprod.total @@ -416,15 +416,15 @@ noncomputable def modBicone (fun j j' => by by_cases h : j = j' · subst h - rw [dif_pos rfl] + rw [dite_eq_left rfl] refine Mod.hom_ext _ _ ?_ - show biproduct.ι (fun j => (M j).X) j + 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 [dif_neg h] + · rw [dite_eq_right h] refine Mod.hom_ext _ _ ?_ - show biproduct.ι (fun j => (M j).X) j + change biproduct.ι (fun j => (M j).X) j ≫ biproduct.π (fun j => (M j).X) j' = _ rw [biproduct.ι_π_ne _ h] rfl) @@ -573,7 +573,7 @@ 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 - show Mono (kernel.ι f.hom) + change Mono (kernel.ι f.hom) infer_instance) /-- The lift of a module map annihilated by `f` through the @@ -705,7 +705,7 @@ theorem cokerAct_one [Category.{v} D] [MonoidalCategory D] [Preadditive D] (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 - haveI := epi_whiskerLeft_cokernelπ (𝟙_ D) f.hom + 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] @@ -718,7 +718,7 @@ theorem cokerAct_mul [Category.{v} D] [MonoidalCategory D] [Preadditive D] μ[A] ▷ cokernel f.hom ≫ cokerAct A f = (α_ A A (cokernel f.hom)).hom ≫ A ◁ cokerAct A f ≫ cokerAct A f := by - haveI := epi_whiskerLeft_cokernelπ (A ⊗ A) f.hom + 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, @@ -778,7 +778,7 @@ theorem epi_cokerProj [Category.{v} D] [MonoidalCategory D] [Preadditive D] (A : D) [MonObj A] {M : Mod D A} {N : Mod D A} (f : M ⟶ N) : Epi (cokerProj A f) := epi_of_epi_hom _ (by - show Epi (cokernel.π f.hom) + change Epi (cokernel.π f.hom) infer_instance) /-- The descent of a module map annihilating `f` through the @@ -795,7 +795,7 @@ noncomputable def cokerDesc (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 - haveI := epi_whiskerLeft_cokernelπ A f.hom + 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, @@ -1035,7 +1035,7 @@ theorem epiDescHom_lin [Category.{v} D] [MonoidalCategory D] [Abelian D] (hk : kerIncl A φ ≫ k = 0) : actLeft A N.X ≫ epiDescHom A φ k hk = A ◁ epiDescHom A φ k hk ≫ actLeft A W.X := by - haveI := epi_whiskerLeft A (e := φ.hom) + 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, @@ -1221,7 +1221,7 @@ theorem retractionBicone_total + (retractionBicone k r hr).snd ≫ (retractionBicone k r hr).inr = 𝟙 (retractionBicone k r hr).pt := by - show r ≫ k + cokernel.π k ≫ retractionSection k r hr = 𝟙 N + change r ≫ k + cokernel.π k ≫ retractionSection k r hr = 𝟙 N rw [π_retractionSection] abel @@ -1299,7 +1299,7 @@ theorem sectionBicone_total (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 - show sectionRetraction c s hs ≫ kernel.ι c + c ≫ s = 𝟙 N + change sectionRetraction c s hs ≫ kernel.ι c + c ≫ s = 𝟙 N rw [sectionRetraction_ι] abel @@ -1332,8 +1332,8 @@ theorem exists_subobject_of_mono_biprod [Category.{v} E] [Abelian E] = (kernel.ι (f ≫ biprod.snd) ≫ f ≫ biprod.fst) ≫ biprod.inl := by refine biprod.hom_ext _ _ ?_ ?_ <;> simp [Category.assoc] - haveI : Mono (kernel.ι (f ≫ biprod.snd) ≫ f) := mono_comp _ _ - haveI : Mono (kernel.ι (f ≫ biprod.snd) ≫ f ≫ biprod.fst) := + 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, ?_⟩ @@ -1350,7 +1350,7 @@ theorem exists_subobject_of_mono_biprod [Category.{v} E] [Abelian E] = 𝟙 (kernel (f ≫ biprod.snd)) := hKz.eq_of_tgt _ _ exact Or.inl ⟨isoBiprodOfRetraction _ 0 hr ≪≫ (isoZeroBiprod hKz).symm⟩ - · haveI : IsIso (kernel.ι (f ≫ biprod.snd) ≫ f ≫ biprod.fst) := + · have : IsIso (kernel.ι (f ≫ biprod.snd) ≫ f ≫ biprod.fst) := isIso_of_mono_of_nonzero hu have hr : kernel.ι (f ≫ biprod.snd) ≫ ((f ≫ biprod.fst) @@ -1378,7 +1378,7 @@ theorem exists_quotient_of_epi_biprod [Category.{v} E] [Abelian E] = biprod.fst ≫ (biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f)) := by refine biprod.hom_ext' _ _ ?_ ?_ <;> simp [hg] - haveI : Epi (biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f)) := by + 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) @@ -1398,7 +1398,7 @@ theorem exists_quotient_of_epi_biprod [Category.{v} E] [Abelian E] = 𝟙 (cokernel (biprod.inr ≫ f)) := hCz.eq_of_src _ _ exact Or.inl ⟨isoBiprodOfSection _ 0 hs ≪≫ (isoBiprodZero hCz).symm⟩ - · haveI : IsIso (biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f)) := + · 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)) @@ -1438,7 +1438,7 @@ theorem exists_sublist_iso_of_mono [Category.{v} E] [Abelian E] induction L with | nil => intro _ N f hf - haveI := hf + have := hf refine ⟨[], List.Sublist.refl _, ⟨?_⟩⟩ have h0 : IsZero N := by rw [IsZero.iff_id_eq_zero] @@ -1447,8 +1447,8 @@ theorem exists_sublist_iso_of_mono [Category.{v} E] [Abelian E] exact h0.iso (isZero_zero E) | cons i L₀ ih => intro hS N f hf - haveI : Simple (S i) := hS i (List.mem_cons_self ..) - haveI : Mono (show N ⟶ (S i ⊞ idxSum S L₀) from 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 @@ -1472,7 +1472,7 @@ theorem exists_sublist_iso_of_epi [Category.{v} E] [Abelian E] induction L with | nil => intro _ N f hf - haveI := hf + have := hf refine ⟨[], List.Sublist.refl _, ⟨?_⟩⟩ have h0 : IsZero N := by rw [IsZero.iff_id_eq_zero] @@ -1481,8 +1481,8 @@ theorem exists_sublist_iso_of_epi [Category.{v} E] [Abelian E] exact h0.iso (isZero_zero E) | cons i L₀ ih => intro hS N f hf - haveI : Simple (S i) := hS i (List.mem_cons_self ..) - haveI : Epi (show (S i ⊞ idxSum S L₀) ⟶ N from 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 @@ -1593,7 +1593,7 @@ noncomputable def biproductFinSuccIso [Category.{v} E] [Abelian E] (⨁ S) ≅ (S 0 ⊞ ⨁ fun i : Fin n => S i.succ) := biprod.uniqueUpToIso _ _ (isBinaryBilimitOfTotal (finSuccBicone S) (by - show biproduct.π S 0 ≫ biproduct.ι S 0 + 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) @@ -1636,7 +1636,7 @@ theorem exists_sublist_iso_biproduct_of_mono [Category.{v} E] [Abelian E] ∃ L : List (Fin n), L.Sublist (List.finRange n) ∧ Nonempty (N ≅ idxSum S L) := by obtain ⟨e⟩ := nonempty_biproduct_iso_idxSum n S - haveI := hf + have := hf exact exists_sublist_iso_of_mono S (List.finRange n) (fun j _ => hS j) (f ≫ e.hom) inferInstance diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAssoc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAssoc.lean index 92f723efc2..fbcd350388 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAssoc.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAssoc.lean @@ -195,7 +195,7 @@ theorem modTensorAssocMid_cond rw [modTensorLegM, modTensorLegN, Category.assoc] at h exact h refine (cancel_epi ((modTensorπ A M N ▷ A) ▷ P.X)).mp ?_ - show ((modTensorπ A M N ▷ A) ▷ P.X) ≫ + 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 = @@ -212,7 +212,7 @@ theorem modTensorAssocMid_cond conv_rhs => rw [associator_naturality_left_assoc, ← whisker_exchange_assoc, whiskerRight_modTensorπ_assocMid, modTensorAssocCover, associator_naturality_right_assoc] - simp only [MonoidalCategory.whiskerLeft_comp, Category.assoc] + simp only [MonoidalCategory.whiskerLeft_comp] repeat' erw [Category.assoc] erw [pentagon_assoc] @@ -327,7 +327,7 @@ theorem modTensorAssocInvMid_cond rw [modTensorLegM, modTensorLegN, Category.assoc] at h exact h apply modTensor_whisker_hom_ext A N P (M.X ⊗ A) - show ((M.X ⊗ A) ◁ modTensorπ A N P) ≫ + 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) ≫ @@ -389,7 +389,7 @@ theorem modTensorAssocHom_assocInv 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 - show (modTensorπ A M N ▷ P.X) ≫ modTensorAssocMid A M N P ≫ + 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 @@ -414,7 +414,7 @@ theorem modTensorAssocInv_assocHom 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 - show (M.X ◁ modTensorπ A N P) ≫ modTensorAssocInvMid A M N P ≫ + 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) @@ -516,7 +516,7 @@ theorem modTensorAssocInv_act modTensorAssocInv A M N P = (A ◁ modTensorAssocInv A M N P) ≫ modTensorAct A (modTensorMod A M N) P := by - haveI : IsIso (modTensorAssocHom A M N P) := + have : IsIso (modTensorAssocHom A M N P) := ⟨modTensorAssocInv A M N P, modTensorAssocHom_assocInv A M N P, modTensorAssocInv_assocHom A M N P⟩ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModBiprod.lean index 1d0a415bf9..cfbef5a5a9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModBiprod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModBiprod.lean @@ -245,7 +245,7 @@ noncomputable def modBiprodMapIso inv := modBiprodMap A M' N' e₁.inv e₂.inv hom_inv_id := by apply Mod.Hom.ext - show biprod.map e₁.hom.hom e₂.hom.hom ≫ + 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 := @@ -261,7 +261,7 @@ noncomputable def modBiprodMapIso Category.comp_id, Category.id_comp] inv_hom_id := by apply Mod.Hom.ext - show biprod.map e₁.inv.hom e₂.inv.hom ≫ + 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 := @@ -320,12 +320,12 @@ noncomputable def modBiprodSymmIso exact modBiprodAct_braiding A N M) hom_inv_id := by apply Mod.Hom.ext - show (biprod.braiding M.X N.X).hom ≫ + 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 - show (biprod.braiding N.X M.X).hom ≫ + 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 @@ -376,7 +376,7 @@ theorem modBiprodAct_associator (A ◁ biprod.fst) ≫ modBiprodAct A M N ≫ g := by intro Z g rw [← Category.assoc, h1, Category.assoc] - show actLeftNest A M N P ≫ + change actLeftNest A M N P ≫ biprod.lift (biprod.fst ≫ biprod.fst) (biprod.lift (biprod.fst ≫ biprod.snd) biprod.snd) = @@ -420,7 +420,7 @@ noncomputable def modBiprodAssocIso 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 - show actRightNest A M N P ≫ + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModContractL.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModContractL.lean index 0d0a6e9913..8fed27facf 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModContractL.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModContractL.lean @@ -73,7 +73,7 @@ theorem window_contract3LFold contract3LFold A p N = ((w ≫ modTensorπ A M' M ≫ p) ▷ (N.X ⊗ 𝟙_ D)) ≫ modListHeadAct A N [] ≫ modMultiπ A [N] := by - show ((w ▷ (N.X ⊗ 𝟙_ D)) ≫ (α_ M'.X M.X (N.X ⊗ 𝟙_ D)).hom) ≫ + 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] = _ @@ -91,7 +91,7 @@ theorem contract3LFold_pair_cond (N : Mod D A) : modMultiLegM A [] M' M [N] ≫ contract3LFold A p N = modMultiLegN A [] M' M [N] ≫ contract3LFold A p N := by - show ((modTensorLegM A M' M ▷ modList A [N]) ≫ + 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]) ≫ @@ -119,7 +119,7 @@ theorem contract3LFold_boundary_cond (N : Mod D A) : modMultiLegM A [M'] M N [] ≫ contract3LFold A p N = modMultiLegN A [M'] M N [] ≫ contract3LFold A p N := by - show (M'.X ◁ (((actRight A M.X ▷ N.X) ▷ (𝟙_ D)) ≫ + 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)) ≫ @@ -153,11 +153,11 @@ theorem contract3LFold_boundary_cond 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 - show (M'.X ◁ ((β_ M.X A).hom ≫ actLeft A M.X)) ≫ + 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] - show (M'.X ◁ (β_ M.X A).hom) ≫ (α_ M'.X A M.X).inv ≫ + 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, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModCross.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModCross.lean index 20833f94c9..31919bb0d7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModCross.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModCross.lean @@ -161,7 +161,7 @@ lemma modCrossBridge_legM (modCrossHeadWin A X [] (Y :: m)) pre = modCrossBridge A X Y m pre ≫ modMultiLegM A pre X Y m | [] => by - show (((β_ (X.X ⊗ 𝟙_ D) A).hom ≫ + 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 ≫ @@ -188,7 +188,7 @@ lemma modCrossBridge_legM associator_naturality_left_assoc, Iso.inv_hom_id_assoc] rw [reassoc_of% hcoh] | P :: rest => by - show P.X ◁ modCrossLegOf A [X] (Y :: m) + 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) @@ -205,7 +205,7 @@ lemma modCrossBridge_legN (modCrossYWin A [X] Y m) pre = modCrossBridge A X Y m pre ≫ modMultiLegN A pre X Y m | [] => by - show (α_ (X.X ⊗ 𝟙_ D) A (Y.X ⊗ modList A m)).hom ≫ + 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))) ≫ @@ -236,7 +236,7 @@ lemma modCrossBridge_legN simp only [MonoidalCategory.whiskerLeft_comp] rw [reassoc_of% hcoh] | P :: rest => by - show P.X ◁ modCrossLegOf A [X] (Y :: m) + 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) @@ -283,7 +283,7 @@ lemma modCrossPeel_yWin [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] | [], h => by simp only [List.nil_append, List.cons_append, modListCast_rfl, Category.comp_id] - show (((α_ X.X (modList A Xs') A).hom ▷ modList A (Y :: m)) ≫ + 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) ≫ @@ -304,7 +304,7 @@ lemma modCrossPeel_yWin [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] conv_rhs => rw [associator_naturality_right_assoc] rw [reassoc_of% hcoh] | P :: rest, h => by - show (P.X ◁ modCrossPeel A X Xs' (Y :: m) rest) ≫ + 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 = @@ -348,7 +348,7 @@ lemma modCrossStepBridge_legM modCrossStepBridge A X P l' Ys pre ≫ modMultiLegM A pre X P (l' ++ Ys) | [] => by - show (((β_ (X.X ⊗ (P.X ⊗ modList A l')) A).hom ≫ + 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) ≫ @@ -377,7 +377,7 @@ lemma modCrossStepBridge_legM whisker_exchange_assoc, whisker_exchange_assoc, whisker_exchange, whisker_exchange_assoc] | Q :: rest => by - show Q.X ◁ modCrossLegOf A (X :: P :: l') Ys + 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)) @@ -404,7 +404,7 @@ lemma modCrossStepBridge_legN | [], h => by simp only [List.nil_append, List.cons_append, modListCast_rfl, Category.comp_id] - show ((((α_ X.X (P.X ⊗ modList A l') A).hom ≫ + 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 ≫ @@ -465,7 +465,7 @@ lemma modCrossStepBridge_legN rest ++ ((X :: P :: l') ++ Ys) := by simp have hQC : Q.X ◁ modListCast A h' = modListCast A h := modListCast_whiskerLeft A Q h' - show (Q.X ◁ modCrossStepBridge A X P l' Ys rest) ≫ + 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 @@ -676,7 +676,7 @@ lemma modTensorLeg_multi (modListHeadAct A X l ▷ modList A (Y :: m)) ≫ (modListConcat A (X :: l) (Y :: m)).hom ≫ modMultiπ A ((X :: l) ++ (Y :: m)) := by - show (modMultiπ A (X :: l) ▷ (A ⊗ modList A (Y :: m))) ≫ + 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 ≫ @@ -699,7 +699,7 @@ lemma modTensorLeg_multi (modList A (X :: l) ◁ modListHeadAct A Y m) ≫ (modListConcat A (X :: l) (Y :: m)).hom ≫ modMultiπ A ((X :: l) ++ (Y :: m)) := by - show (modMultiπ A (X :: l) ▷ (A ⊗ modList A (Y :: m))) ≫ + 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 ≫ @@ -721,7 +721,7 @@ lemma modTensorLeg_multi have mc := modListCross A X Y l m rw [MonoidalCategory.comp_whiskerRight] at mc simp only [Category.assoc] at mc - show (modMultiπ A (X :: l) ▷ (A ⊗ modList A (Y :: m))) ≫ + 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) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModDual.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModDual.lean index 82a1a71983..6c337d8248 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModDual.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModDual.lean @@ -286,7 +286,7 @@ lemma actRight_dualMod [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] [IsCommMonObj A] : haveI := dualModObj A X Y actRight A Y = dualActRight A X Y := by - show (β_ Y A).hom ≫ dualActLeft A X Y = dualActRight A X Y + change (β_ Y A).hom ≫ dualActLeft A X Y = dualActRight A X Y rw [dualActLeft_def, Iso.hom_inv_id_assoc] end DualModule @@ -312,8 +312,8 @@ lemma modTensorLeg_pair [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (ε_ X Y ≫ η[A]) = modTensorLegN A (dualMod A X Y) (asMod A X) ≫ (ε_ X Y ≫ η[A]) := by - letI := dualModObj A X Y - show actRight A Y ▷ X ≫ (ε_ X Y ≫ η[A]) = + 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] @@ -375,8 +375,8 @@ lemma whiskerLeft_modTensorπ_act_modPairing (α_ 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] - letI := dualModObj A X Y - show (α_ A Y X).inv ≫ actLeft A Y ▷ X ≫ ε_ X Y ≫ η[A] = _ + 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean index 1e73674103..76c3293c5b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean @@ -49,22 +49,22 @@ theorem append_pair_slot_cases rcases post.eq_nil_or_concat with h | ⟨post', q, rfl⟩ · subst h have := congrArg List.reverse hd - simp at this + simp? 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 at this + simp? 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 at h4 + simp? at h4 rw [h4] · have := congrArg List.reverse hd - simp at this + simp? at this obtain ⟨h1, h2, h3⟩ := this refine Or.inl ⟨post'', ⟨by rw [show (post''.concat q').concat q = @@ -100,7 +100,7 @@ theorem window_contract3Fold (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 - show (N.X ◁ ((w ▷ (𝟙_ D)) ≫ (α_ M'.X M.X (𝟙_ D)).hom)) ≫ + 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] = _ @@ -130,7 +130,7 @@ theorem contract3Fold_boundary_cond (N : Mod D A) : modMultiLegM A [] N M' [M] ≫ contract3Fold A p N = modMultiLegN A [] N M' [M] ≫ contract3Fold A p N := by - show (((actRight A N.X ▷ M'.X) ▷ (M.X ⊗ 𝟙_ D)) ≫ + 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)) ≫ @@ -238,7 +238,7 @@ noncomputable def modMultiContract3 contract3Fold A p N = modMultiLegN A [N] M' M [] ≫ contract3Fold A p N := by - show (N.X ◁ ((modTensorLegM A M' M ▷ modList A []) ≫ + 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 []) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMulti.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMulti.lean index 9e86777637..8942753570 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMulti.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMulti.lean @@ -526,7 +526,7 @@ 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 - show (X.X ◁ (ρ_ Y.X).hom) ≫ (X.X ◁ (ρ_ Y.X).inv) = + 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] @@ -536,7 +536,7 @@ 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 - show (X.X ◁ (ρ_ Y.X).inv) ≫ (X.X ◁ (ρ_ Y.X).hom) = + 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] @@ -567,7 +567,7 @@ lemma modMultiLeg_pair_resolve 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 - show ((w ▷ 𝟙_ D) ≫ (α_ X.X Y.X (𝟙_ D)).hom) ≫ + 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] @@ -585,7 +585,7 @@ lemma modMultiLeg_pair_resolveInv modListCast A h := by have hcoh : (ρ_ (X.X ⊗ Y.X)).inv ≫ (α_ X.X Y.X (𝟙_ D)).hom = X.X ◁ (ρ_ Y.X).inv := by monoidal - show w ≫ (X.X ◁ (ρ_ Y.X).inv) = + 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)) @@ -700,7 +700,7 @@ lemma modListConcat_cons_whisker ((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 - show ((P.X ◁ u) ▷ modList A Ys) ≫ + 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 ≫ @@ -719,7 +719,7 @@ lemma modListConcat_whiskerLeft_cons (α_ P.X (modList A Xs) S).hom ≫ (P.X ◁ ((modList A Xs ◁ u) ≫ (modListConcat A Xs T).hom)) := by - show ((P.X ⊗ modList A Xs) ◁ u) ≫ + 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 ≫ @@ -765,7 +765,7 @@ lemma modMultiLegOf_concat_nil (modListConcat A (M :: N :: post) Ys).hom = modMultiMidConcat A M N post Ys [] ≫ modMultiLegOf A M N (post ++ Ys) w [] := by - show (((w ▷ modList A post) ≫ + 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 ≫ @@ -800,7 +800,7 @@ lemma modMultiLegOf_concat Category.comp_id] exact modMultiLegOf_concat_nil A M N post Ys w | P :: rest, h => by - show ((P.X ◁ modMultiLegOf A M N post w rest) ▷ modList A Ys) ≫ + 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)) ≫ @@ -841,7 +841,7 @@ lemma modMultiLegOf_concatL modMultiMidConcatL A pre M N post Xs ≫ modMultiLegOf A M N post w (Xs ++ pre) ≫ modListCast A h | [], h => by - show ((𝟙_ D) ◁ modMultiLegOf A M N post w pre) ≫ + 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 ≫ @@ -850,7 +850,7 @@ lemma modMultiLegOf_concatL | P :: rest, h => by rw [modListConcat_whiskerLeft_cons A P rest, modMultiLegOf_concatL A pre M N post w rest (by simp)] - show (α_ P.X (modList A rest) (modMultiMid A pre M N post)).hom ≫ + 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 = @@ -879,11 +879,13 @@ whiskered injections. -/ lemma biproduct_whiskerRight_hom_ext [Category.{v} D] [MonoidalCategory D] [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] - {J : Type} [Fintype J] + {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 @@ -896,11 +898,13 @@ whiskered injections. -/ lemma biproduct_whiskerLeft_hom_ext [Category.{v} D] [MonoidalCategory D] [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] - {J : Type} [Fintype J] + {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 @@ -1260,7 +1264,7 @@ lemma modListHeadAct_window ((α_ A M.X N.X).inv ▷ modList A post) ≫ (α_ (A ⊗ M.X) N.X (modList A post)).hom := by monoidal - show (A ◁ ((w ▷ modList A post) ≫ + 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))) = @@ -1284,7 +1288,7 @@ lemma modListHeadAct_tail {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 - show (A ◁ (X.X ◁ u)) ≫ + 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) @@ -1316,7 +1320,7 @@ lemma modListHeadAct_slotwise subst h1 subst h2 rw [modMultiLegM, modMultiLegN] - show (A ◁ (modMultiLegOf A X N post (modTensorLegM A X N) [] ≫ + 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)) = @@ -1342,7 +1346,7 @@ lemma modListHeadAct_slotwise subst h1 subst h2 rw [modMultiLegM, modMultiLegN] - show (A ◁ ((X.X ◁ modMultiLegOf A M N post + 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) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMultiTriple.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMultiTriple.lean index 1547b1f6fa..ae782daafd 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMultiTriple.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMultiTriple.lean @@ -83,7 +83,7 @@ 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 - show (X.X ◁ (Y.X ◁ (ρ_ Z.X).hom)) ≫ + 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, @@ -95,7 +95,7 @@ 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 - show (X.X ◁ (Y.X ◁ (ρ_ Z.X).inv)) ≫ + 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, @@ -129,7 +129,7 @@ lemma tripleLegFst_resolve tripleResolve A X Y Z = tripleSeedFst A X Y Z ≫ (w ▷ Z.X) ≫ (α_ X.X Y.X Z.X).hom := by - show ((w ▷ (Z.X ⊗ 𝟙_ D)) ≫ + 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)) = @@ -150,7 +150,7 @@ lemma tripleLegFst_resolveInv tripleResolveInv A X Y Z = tripleSeedFstInv A X Y Z ≫ modMultiLegOf A X Y [Z] w [] ≫ modListCast A h := by - show (w ▷ Z.X) ≫ (α_ X.X Y.X Z.X).hom ≫ + 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)) ≫ @@ -185,7 +185,7 @@ lemma tripleLegSnd_resolve modMultiLegOf A Y Z [] w [X] ≫ modListCast A h ≫ tripleResolve A X Y Z = tripleSeedSnd A X Y Z ≫ (X.X ◁ w) := by - show (X.X ◁ ((w ▷ 𝟙_ D) ≫ (α_ Y.X Z.X (𝟙_ D)).hom)) ≫ + 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) @@ -207,7 +207,7 @@ lemma tripleLegSnd_resolveInv (X.X ◁ w) ≫ tripleResolveInv A X Y Z = tripleSeedSndInv A X Y Z ≫ modMultiLegOf A Y Z [] w [X] ≫ modListCast A h := by - show (X.X ◁ w) ≫ (X.X ◁ (Y.X ◁ (ρ_ Z.X).inv)) = + 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)))) @@ -343,7 +343,7 @@ lemma tripleResolveInv_snd_rel have hrel := modMulti_rel A [X] Y Z [] (rfl : [X, Y, Z] = [X] ++ Y :: Z :: []) rw [modMultiLegM, modMultiLegN] at hrel - show (X.X ◁ modTensorLegM A Y Z) ≫ tripleResolveInv A X Y Z ≫ + 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] @@ -389,7 +389,7 @@ lemma tripleInvMid_cond modTensorLegN A (modTensorMod A X Y) Z ≫ tripleInvMid A X Y Z := by refine (cancel_epi ((modTensorπ A X Y ▷ A) ▷ Z.X)).mp ?_ - show ((modTensorπ A X Y ▷ A) ▷ Z.X) ≫ + 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 = @@ -453,7 +453,6 @@ lemma whiskerRight_modTensorπ_tripleInv modMultiTripleInv A X Y Z = (α_ X.X Y.X Z.X).hom ≫ tripleResolveInv A X Y Z ≫ modMultiπ A [X, Y, Z] := by - repeat' erw [Category.assoc] erw [modTensorπ_tripleInv] erw [whiskerRight_modTensorπ_tripleInvMid, tripleInvCover] @@ -491,7 +490,7 @@ lemma modMultiTripleInv_tripleHom apply modTensor_hom_ext rw [modTensorπ_tripleInv_assoc, Category.comp_id] apply modTensor_whiskerR_hom_ext A X Y Z.X - show (modTensorπ A X Y ▷ Z.X) ≫ tripleInvMid A X Y Z ≫ + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescent.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescent.lean index aa0254d848..14072b338f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescent.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescent.lean @@ -77,7 +77,7 @@ theorem sandwichTower_retract modTensorMapMod A (𝟙 (modTensorMod A M M')) rk = 𝟙 (modTensorMod A (modTensorMod A M M') M) := by apply Mod.Hom.ext - show modTensorMap A (𝟙 (modTensorMod A M M')) ik ≫ + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowStage.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowStage.lean index 7c12aa9a16..fa93e505f1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowStage.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowStage.lean @@ -82,7 +82,7 @@ theorem modPowLegM_succ 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 - show ((tensorPow D X a ◁ winLegM A X) ▷ tensorPow D X (b + 1)) ≫ + 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) @@ -98,7 +98,7 @@ theorem modPowLegN_succ 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 - show ((tensorPow D X a ◁ winLegN A X) ▷ tensorPow D X (b + 1)) ≫ + 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchurSummand.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchurSummand.lean index 34dfd4455c..0446afde2b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchurSummand.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchurSummand.lean @@ -64,11 +64,11 @@ theorem ModSchurKilled.of_biprod_left (P : SchurPackage.{v}) {lam : YoungDiagram} (h : ModSchurKilled A (modBiprod A M N).X P lam) : ModSchurKilled A M.X P lam := by - haveI := (modBiprodInl A M N).isModHom - haveI := (modBiprodFst A M N).isModHom + 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 - show (biprod.inl : M.X ⟶ M.X ⊞ N.X) ≫ biprod.fst = 𝟙 M.X + change (biprod.inl : M.X ⟶ M.X ⊞ N.X) ≫ biprod.fst = 𝟙 M.X exact biprod.inl_fst /-- **Module-level Schur vanishing is invariant under @@ -81,8 +81,8 @@ theorem ModSchurKilled.of_modIso (P : SchurPackage.{v}) {lam : YoungDiagram} (h : ModSchurKilled A N.X P lam) : ModSchurKilled A M.X P lam := by - haveI := e.hom.isModHom - haveI := e.inv.isModHom + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean index f79b4c1f63..596c5ecb17 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean @@ -219,7 +219,7 @@ lemma actRight_natural_mod [BraidedCategory D] {M N : Mod D A} (f : M ⟶ N) : actRight A M.X ≫ f.hom = f.hom ▷ A ≫ actRight A N.X := by - haveI := f.isModHom + have := f.isModHom exact actRight_natural A M.X N.X f.hom /-- **The shuffle of two free modules**: multiply the two algebra @@ -239,7 +239,7 @@ lemma actLeft_actRight [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (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 [actRight, actLeft_actLeft] + simp? [actRight, actLeft_actLeft] rw [← comp_whiskerRight_assoc, IsCommMonObj.mul_comm] /-- For a commutative monoid, the braided right action is @@ -250,7 +250,7 @@ lemma actRight_actRight [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (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 [actRight, actLeft_actLeft] + simp? [actRight, actLeft_actLeft] rw [← comp_whiskerRight_assoc, IsCommMonObj.mul_comm] end RightAction @@ -739,7 +739,7 @@ lemma modTensorLegM_regular_actLeft [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 - show ((β_ A A).hom ≫ μ[A]) ▷ N.X ≫ actLeft A N.X = + 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] @@ -749,7 +749,7 @@ lemma modTensorLegM_regular_actRight [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 - show actRight A M.X ▷ A ≫ actRight A M.X = + 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] @@ -766,14 +766,14 @@ noncomputable def modTensorUnitLeft hom_inv_id := by have hM : (((λ_ A).inv ≫ η[A] ▷ A) ▷ N.X) ≫ modTensorLegM A (regularMod A) N = 𝟙 (A ⊗ N.X) := by - show (((λ_ A).inv ≫ η[A] ▷ A) ▷ N.X) ≫ + 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 - show (((λ_ A).inv ≫ η[A] ▷ A) ▷ N.X) ≫ + 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] @@ -800,14 +800,14 @@ noncomputable def modTensorUnitRight 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 - show ((ρ_ (M.X ⊗ A)).inv ≫ (M.X ⊗ A) ◁ η[A]) ≫ + 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 - show ((ρ_ (M.X ⊗ A)).inv ≫ (M.X ⊗ A) ◁ η[A]) ≫ + 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, @@ -939,7 +939,7 @@ lemma modTensorAct_map [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] 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 + simp? rw [← tensorHom_id (actLeft A M.X) N.X, ← tensorHom_id (actLeft A M'.X) N'.X, tensorHom_comp_tensorHom, tensorHom_comp_tensorHom] @@ -973,12 +973,12 @@ noncomputable def modTensorMapIso hom := modTensorMapMod A e.hom f.hom inv := modTensorMapMod A e.inv f.inv hom_inv_id := Mod.hom_ext _ _ (by - show modTensorMap A e.hom f.hom ≫ + 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 - show modTensorMap A e.inv f.inv ≫ + 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]) @@ -1006,7 +1006,7 @@ lemma actRight_restrictRegular haveI := ModObj.regular B haveI := Mod.scalarRestriction φ B actRight A B = B ◁ φ ≫ μ[B] := by - show (β_ B A).hom ≫ φ ▷ B ≫ μ[B] = B ◁ φ ≫ μ[B] + change (β_ B A).hom ≫ φ ▷ B ≫ μ[B] = B ◁ φ ≫ μ[B] rw [← BraidedCategory.braiding_naturality_right_assoc, IsCommMonObj.mul_comm] @@ -1059,7 +1059,7 @@ noncomputable def baseChangeAct (baseChangeModObj φ M).smul /-- Defining equation of the `B`-action on the base change. -/ -@[reassoc (attr := simp)] +@[simp, reassoc] lemma whiskerLeft_modTensorπ_baseChangeAct [Category.{v} D] [MonoidalCategory D] {A : D} {B : D} [MonObj A] [MonObj B] (φ : A ⟶ B) [IsMonHom φ] [BraidedCategory D] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/NewtonConv.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NewtonConv.lean index 573585fe58..766f84d2a4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/NewtonConv.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NewtonConv.lean @@ -48,7 +48,8 @@ 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) + (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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/NullPoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NullPoint.lean index 48c7fa1e72..9c187362cd 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/NullPoint.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NullPoint.lean @@ -23,11 +23,11 @@ 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 - haveI := hm - letI := Ideal.Quotient.field m - haveI : Module.Finite ℂ (R ⧸ m) := + have := hm + let := Ideal.Quotient.field m + have : Module.Finite ℂ (R ⧸ m) := finite_of_finite_type_of_isJacobsonRing ℂ (R ⧸ m) - haveI : Algebra.IsAlgebraic ℂ (R ⧸ m) := + have : Algebra.IsAlgebraic ℂ (R ⧸ m) := Algebra.IsAlgebraic.of_finite ℂ (R ⧸ m) exact ⟨(IsAlgClosed.lift (M := ℂ)).comp (Ideal.Quotient.mkₐ ℂ m)⟩ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLinePairing.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLinePairing.lean index 43e62e92e7..820ebeadd6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLinePairing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLinePairing.lean @@ -31,7 +31,7 @@ theorem neg_id_whiskerRight [MonoidalPreadditive D] (X Y : D) : (-𝟙 X) ▷ Y = -𝟙 (X ⊗ Y) := by - show (tensorRight Y).map (-𝟙 X) = _ + change (tensorRight Y).map (-𝟙 X) = _ rw [Functor.map_neg] simp @@ -40,7 +40,7 @@ theorem whiskerLeft_neg_id [Category.{v} D] [MonoidalCategory D] [Preadditive D] [MonoidalPreadditive D] (X Y : D) : X ◁ (-𝟙 Y) = -𝟙 (X ⊗ Y) := by - show (tensorLeft X).map (-𝟙 Y) = _ + change (tensorLeft X).map (-𝟙 Y) = _ rw [Functor.map_neg] simp diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddParity.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddParity.lean index 1a7529d10c..b2cb509b91 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddParity.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddParity.lean @@ -69,10 +69,10 @@ noncomputable def oddParitySwap Linear.smul_comp] invFun g := L.sq.inv ≫ (g ▷ L.obj) left_inv f := by - show L.sq.inv ≫ (((λ_ L.obj).inv ≫ (f ▷ L.obj) ≫ + 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 - letI := L.exactPairing + 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 ≫ @@ -85,9 +85,9 @@ noncomputable def oddParitySwap rw [← hs, L.coevaluation_whiskerRight, ← ht, Equiv.apply_symm_apply] right_inv g := by - show (λ_ L.obj).inv ≫ ((L.sq.inv ≫ (g ▷ L.obj)) ▷ L.obj) ≫ + 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 - letI := L.exactPairing + 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 ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquare.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquare.lean index d9d1353e8c..366e02a1a1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquare.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquare.lean @@ -95,7 +95,7 @@ theorem tensorμ_oddLine (A : D) : tensorμ A L.obj L.obj L.obj = -𝟙 ((A ⊗ L.obj) ⊗ (L.obj ⊗ L.obj)) := by - show (α_ A L.obj (L.obj ⊗ L.obj)).hom ≫ + 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) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquareIso.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquareIso.lean index 1b3aa0b393..e8dd7ecc56 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquareIso.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquareIso.lean @@ -121,7 +121,7 @@ private theorem oddSqMap_ee (λ_ (𝟙_ D)).inv ≫ (u ⊗ₘ v) ≫ freeModShuffle R L.obj L.obj ≫ (R ◁ L.sq.hom) ≫ (ρ_ R).hom := by - show ((fibreMu L R L.obj L.obj).evenMap (tmulEE _ _ u v) ≫ + 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 _ _ _) ?_ @@ -139,7 +139,7 @@ private theorem oddSqMap_oo L.sq.inv ≫ (u ⊗ₘ v) ≫ freeModShuffle R L.obj L.obj ≫ (R ◁ L.sq.hom) ≫ (ρ_ R).hom := by - show ((fibreMu L R L.obj L.obj).evenMap (tmulOO _ _ u v) ≫ + 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 _ _ _) ?_ @@ -158,7 +158,7 @@ private theorem oddSqMap_eo (λ_ L.obj).inv ≫ (u ⊗ₘ v) ≫ freeModShuffle R L.obj L.obj ≫ (R ◁ L.sq.hom) ≫ (ρ_ R).hom := by - show ((fibreMu L R L.obj L.obj).oddMap (tmulEO _ _ u v) ≫ + 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 _ _ _) ?_ @@ -177,7 +177,7 @@ private theorem oddSqMap_oe (ρ_ L.obj).inv ≫ (u ⊗ₘ v) ≫ freeModShuffle R L.obj L.obj ≫ (R ◁ L.sq.hom) ≫ (ρ_ R).hom := by - show ((fibreMu L R L.obj L.obj).oddMap (tmulOE _ _ u v) ≫ + 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 _ _ _) ?_ @@ -209,7 +209,7 @@ private theorem oddSqShift_ee (oddSqShift L R).evenMap (tmulEE _ _ (L.sq.inv ≫ (a ▷ L.obj)) (L.sq.inv ≫ (b ▷ L.obj))) = L.sq.inv ≫ (a ⊗ₘ b) ≫ μ[R] := by - show (shiftUnitHom (shift (gammaAlgebra D L R).unitMod)).evenMap + 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))) @@ -227,7 +227,7 @@ private theorem oddSqShift_oo ((λ_ L.obj).inv ≫ (x ▷ L.obj)) ((λ_ L.obj).inv ≫ (y ▷ L.obj))) = -((λ_ (𝟙_ D)).inv ≫ (x ⊗ₘ y) ≫ μ[R]) := by - show (shiftUnitHom (shift (gammaAlgebra D L R).unitMod)).evenMap + 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))) @@ -245,7 +245,7 @@ private theorem oddSqShift_eo (L.sq.inv ≫ (a ▷ L.obj)) ((λ_ L.obj).inv ≫ (x ▷ L.obj))) = -((ρ_ L.obj).inv ≫ (a ⊗ₘ x) ≫ μ[R]) := by - show (shiftUnitHom (shift (gammaAlgebra D L R).unitMod)).oddMap + 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))) @@ -263,7 +263,7 @@ private theorem oddSqShift_oe ((λ_ L.obj).inv ≫ (x ▷ L.obj)) (L.sq.inv ≫ (a ▷ L.obj))) = (λ_ L.obj).inv ≫ (x ⊗ₘ a) ≫ μ[R] := by - show (shiftUnitHom (shift (gammaAlgebra D L R).unitMod)).oddMap + 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))) @@ -340,28 +340,28 @@ theorem isIso_gammaPairComparison_oddSquare [∀ Z : D, PreservesColimitsOfShape WalkingParallelPair (tensorLeft Z)] : IsIso (gammaPairComparison L R (freeMod R L.obj) (freeMod R L.obj)) := by - haveI hsh : IsIso (oddSqShift L R) := + 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 - haveI hmap : IsIso (oddSqMap L R) := by + 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] - haveI h1 : IsIso (gammaFunMap L R (freeModMap R L.sq.hom)) := + have h1 : IsIso (gammaFunMap L R (freeModMap R L.sq.hom)) := ((gammaModuleFunctor L R).mapIso (freeModMapIso R L.sq)).isIso_hom - haveI h2 : IsIso (gammaFunMap L R (freeModUnitIso R).hom) := + have h2 : IsIso (gammaFunMap L R (freeModUnitIso R).hom) := ((gammaModuleFunctor L R).mapIso (freeModUnitIso R)).isIso_hom - haveI h3 : IsIso (gammaFunMap L R (freeModMap R L.sq.hom) ≫ + have h3 : IsIso (gammaFunMap L R (freeModMap R L.sq.hom) ≫ gammaFunMap L R (freeModUnitIso R).hom) := IsIso.comp_isIso - haveI h4 : IsIso (gammaFunMap L R + 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 - haveI hmu : IsIso (gammaPairComparison L R (freeMod R L.obj) + 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 _ _ _ _ _ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairCarrier.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairCarrier.lean index 3aea43a544..e988c7f6f9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairCarrier.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairCarrier.lean @@ -92,7 +92,7 @@ theorem copairUnit_splitPairMul chainBGrι A M M' d 0 := by erw [chainBGrUnit, ← Category.assoc, chainBUnit_chainBGrComponentZeroIso_inv, Category.assoc] - show copairUnit A M M' d ≫ chainPairMul A M M' d ≫ + 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) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairMul.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairMul.lean index ff3a0fa7ab..7ab5feb76a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairMul.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairMul.lean @@ -166,7 +166,7 @@ theorem interchange_legM show actRight A (modTensorMod A N₁ P₁).X = (β_ (modTensor A N₁ P₁) A).hom ≫ modTensorAct A N₁ P₁ from rfl] - show ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ modTensorπ A N₂ P₂) ≫ + 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] @@ -240,7 +240,7 @@ theorem interchange_legN rw [modTensorLegN, show actLeft A (modTensorMod A N₂ P₂).X = modTensorAct A N₂ P₂ from rfl] - show ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ modTensorπ A N₂ P₂) ≫ + 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] @@ -375,7 +375,7 @@ theorem interchange_legMP show actRight A (modTensorMod A N₁ P₁).X = (β_ (modTensor A N₁ P₁) A).hom ≫ modTensorAct A N₁ P₁ from rfl] - show ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ modTensorπ A N₂ P₂) ≫ + 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] @@ -512,7 +512,7 @@ theorem interchange_legNP rw [modTensorLegN, show actLeft A (modTensorMod A N₂ P₂).X = modTensorAct A N₂ P₂ from rfl] - show ((modTensorπ A N₁ P₁ ▷ A) ⊗ₘ modTensorπ A N₂ P₂) ≫ + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairPerm.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairPerm.lean index d04f95042a..840d81e5f7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairPerm.lean @@ -197,7 +197,7 @@ theorem powPeel_permMor_swap (Equiv.swap ⟨a, by omega⟩ ⟨a + 1, by omega⟩)) | q, a, 0, h => by subst h - show permMor X (a + 1 + 2) topSwap ≫ + change permMor X (a + 1 + 2) topSwap ≫ (powPeel X (a + 2)).hom = (powPeel X (a + 2)).hom ≫ (X ◁ permMor X (a + 2) topSwap) @@ -205,7 +205,7 @@ theorem powPeel_permMor_swap exact swapTop_powPeel X a | q, a, b + 1, h => by subst h - show permMor X (a + 2 + b + 1 + 1) + 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 ≫ @@ -284,13 +284,13 @@ theorem powPeel_permMor_low ((β_ X X).hom ▷ tensorPow D X n) ≫ (α_ X X (tensorPow D X n)).hom | 0 => by - show permMor X (0 + 2) topSwap ≫ + 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] - show ((α_ (𝟙_ D) X X).hom ≫ (𝟙_ D ◁ (β_ X X).hom) ≫ + change ((α_ (𝟙_ D) X X).hom ≫ (𝟙_ D ◁ (β_ X X).hom) ≫ (α_ (𝟙_ D) X X).inv) ≫ ((((λ_ X).hom ≫ (ρ_ X).inv) ▷ X) ≫ (α_ X (𝟙_ D) X).hom) ≫ @@ -302,7 +302,7 @@ theorem powPeel_permMor_low (α_ X X (𝟙_ D)).hom monoidal | n + 1 => by - show permMor X (n + 2 + 1) + 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) = diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermNat.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermNat.lean index d41bdce783..28b25830f0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermNat.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermNat.lean @@ -96,18 +96,18 @@ theorem tensorPowMap_mono [Category.{v} A] [MonoidalCategory A] | zero => exact inferInstanceAs (Mono (𝟙 (𝟙_ A))) | succ n ih => - haveI : PreservesLimitsOfSize.{0, 0} (tensorRight X) := + have : PreservesLimitsOfSize.{0, 0} (tensorRight X) := preservesSmallestLimits_of_preservesLimits _ - haveI : PreservesLimitsOfSize.{0, 0} + have : PreservesLimitsOfSize.{0, 0} (tensorLeft (tensorPow A Y n)) := preservesSmallestLimits_of_preservesLimits _ - haveI := ih - haveI : Mono (tensorPowMap f n ▷ X) := + have := ih + have : Mono (tensorPowMap f n ▷ X) := (tensorRight X).map_mono (tensorPowMap f n) - haveI : Mono (tensorPow A Y n ◁ f) := + have : Mono (tensorPow A Y n ◁ f) := (tensorLeft (tensorPow A Y n)).map_mono f rw [tensorPowMap_succ, MonoidalCategory.tensorHom_def] - show Mono ((tensorPowMap f n ▷ X) ≫ (tensorPow A Y n ◁ f)) + change Mono ((tensorPowMap f n ▷ X) ≫ (tensorPow A Y n ◁ f)) exact mono_comp _ _ /-- **Tensor powers preserve monomorphisms**, from mono @@ -122,13 +122,13 @@ theorem tensorPowMap_mono' [Category.{v} A] [MonoidalCategory A] | zero => exact inferInstanceAs (Mono (𝟙 (𝟙_ A))) | succ n ih => - haveI := ih - haveI : Mono (tensorPowMap f n ▷ X) := + have := ih + have : Mono (tensorPowMap f n ▷ X) := (tensorRight X).map_mono (tensorPowMap f n) - haveI : Mono (tensorPow A Y n ◁ f) := + have : Mono (tensorPow A Y n ◁ f) := (tensorLeft (tensorPow A Y n)).map_mono f rw [tensorPowMap_succ, MonoidalCategory.tensorHom_def] - show Mono ((tensorPowMap f n ▷ X) ≫ + change Mono ((tensorPowMap f n ▷ X) ≫ (tensorPow A Y n ◁ f)) exact mono_comp _ _ @@ -142,18 +142,18 @@ theorem tensorPowMap_epi [Category.{v} A] [MonoidalCategory A] | zero => exact inferInstanceAs (Epi (𝟙 (𝟙_ A))) | succ n ih => - haveI : PreservesColimitsOfSize.{0, 0} (tensorRight X) := + have : PreservesColimitsOfSize.{0, 0} (tensorRight X) := preservesSmallestColimits_of_preservesColimits _ - haveI : PreservesColimitsOfSize.{0, 0} + have : PreservesColimitsOfSize.{0, 0} (tensorLeft (tensorPow A Y n)) := preservesSmallestColimits_of_preservesColimits _ - haveI := ih - haveI : Epi (tensorPowMap f n ▷ X) := + have := ih + have : Epi (tensorPowMap f n ▷ X) := (tensorRight X).map_epi (tensorPowMap f n) - haveI : Epi (tensorPow A Y n ◁ f) := + have : Epi (tensorPow A Y n ◁ f) := (tensorLeft (tensorPow A Y n)).map_epi f rw [tensorPowMap_succ, MonoidalCategory.tensorHom_def] - show Epi ((tensorPowMap f n ▷ X) ≫ (tensorPow A Y n ◁ f)) + change Epi ((tensorPowMap f n ▷ X) ≫ (tensorPow A Y n ◁ f)) exact epi_comp _ _ /-! ## Naturality of the action @@ -274,7 +274,7 @@ theorem permMor_natural induction n with | zero => intro σ - show 𝟙 (𝟙_ A) ≫ 𝟙 (𝟙_ A) = 𝟙 (𝟙_ A) ≫ 𝟙 (𝟙_ A) + change 𝟙 (𝟙_ A) ≫ 𝟙 (𝟙_ A) = 𝟙 (𝟙_ A) ≫ 𝟙 (𝟙_ A) rfl | succ n ih => intro σ @@ -356,7 +356,7 @@ theorem SchurKilled.of_mono [RigidCategory A] (P : SchurPackage.{v}) {X Y : A} (f : Y ⟶ X) [Mono f] {μ : YoungDiagram} (h : SchurKilled P X μ) : SchurKilled P Y μ := by - haveI := tensorPowMap_mono f μ.card + have := tensorPowMap_mono f μ.card exact zero_of_intertwine_mono (permAlg_natural f μ.card (P.e μ)) h /-- **Schur vanishing descends along epimorphisms** (the quotient @@ -367,7 +367,7 @@ theorem SchurKilled.of_epi [RigidCategory A] (P : SchurPackage.{v}) {X Y : A} (f : X ⟶ Y) [Epi f] {μ : YoungDiagram} (h : SchurKilled P X μ) : SchurKilled P Y μ := by - haveI := tensorPowMap_epi f μ.card + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermRepChar.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermRepChar.lean index f2c3505575..0fa4cbb655 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermRepChar.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermRepChar.lean @@ -30,7 +30,7 @@ namespace RS open Finset Equiv MonoidAlgebra -open scoped Classical + /-! ### The colour space and its permutation action -/ @@ -56,7 +56,7 @@ instance colourSpace.mulAction {n p : ℕ} : funext i rfl mul_smul π ρ g := by - show g ∘ ⇑(π * ρ)⁻¹ = (g ∘ ⇑ρ⁻¹) ∘ ⇑π⁻¹ + change g ∘ ⇑(π * ρ)⁻¹ = (g ∘ ⇑ρ⁻¹) ∘ ⇑π⁻¹ rw [mul_inv_rev] rfl @@ -79,7 +79,7 @@ private theorem fixed_iff_comp_eq {n p : ℕ} (π : Equiv.Perm (Fin n)) exact this.symm · intro h funext i - show g (π⁻¹ i) = g i + change g (π⁻¹ i) = g i have := congrFun h (π⁻¹ i) change g (π (π⁻¹ i)) = g (π⁻¹ i) at this simp at this @@ -92,10 +92,10 @@ private theorem char_permRep_count (p n : ℕ) (permRep p n).character π = ((Finset.univ.filter (fun g : colourSpace n p => π • g = g)).card : ℂ) := by - show LinearMap.trace ℂ _ ((permRep p n) π) = _ + change LinearMap.trace ℂ _ ((permRep p n) π) = _ set b := MonoidAlgebra.basis (colourSpace n p) ℂ with hb_def rw [LinearMap.trace_eq_matrix_trace ℂ b] - show ∑ g : colourSpace n p, + 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 = @@ -107,15 +107,16 @@ private theorem char_permRep_count (p n : ℕ) rw [show (permRep p n) π (MonoidAlgebra.single g 1) = MonoidAlgebra.single (π • g) 1 from Representation.ofMulAction_single π g 1] - show ((coeffLinearEquiv ℂ) + change ((coeffLinearEquiv ℂ) (MonoidAlgebra.single (π • g) (1 : ℂ))) g = if π • g = g then 1 else 0 rw [coeffLinearEquiv_apply] - simp [MonoidAlgebra.coeff, Finsupp.single_apply, eq_comm] + 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 = @@ -169,7 +170,7 @@ noncomputable def signRep (n : ℕ) : map_one' := by simp [Module.End.one_eq_id] map_mul' π ρ := by refine LinearMap.ext fun z => ?_ - show ((Equiv.Perm.sign (π * ρ) : ℤ) : ℂ) • z = + change ((Equiv.Perm.sign (π * ρ) : ℤ) : ℂ) • z = ((Equiv.Perm.sign π : ℤ) : ℂ) • (((Equiv.Perm.sign ρ : ℤ) : ℂ) • z) rw [map_mul] @@ -179,7 +180,7 @@ noncomputable def signRep (n : ℕ) : /-- The character of the sign representation is the sign. -/ theorem char_signRep (n : ℕ) (π : Equiv.Perm (Fin n)) : (signRep n).character π = ((Equiv.Perm.sign π : ℤ) : ℂ) := by - show LinearMap.trace ℂ ℂ + change LinearMap.trace ℂ ℂ (((Equiv.Perm.sign π : ℤ) : ℂ) • LinearMap.id) = _ rw [map_smul, LinearMap.trace_id] simp @@ -215,7 +216,7 @@ theorem cycleFun_superPS_e {n : ℕ} (q : ℕ) fun c => ((fun c => (-1 : ℂ) ^ (c + 1)) c) * ((fun _ => (q : ℂ)) c) from by funext c - show superPS 0 q c = (-1 : ℂ) ^ (c + 1) * (q : ℂ) + change superPS 0 q c = (-1 : ℂ) ^ (c + 1) * (q : ℂ) simp [superPS]] rw [cycleFun_mul] rw [show cycleFun (fun _ => (q : ℂ)) π = @@ -234,7 +235,7 @@ 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 - show (Representation.tprod (signRep n) + change (Representation.tprod (signRep n) (permRep q n)).character π = _ rw [Representation.char_tensor] rfl @@ -260,7 +261,7 @@ theorem diagramSchur_superPS_h_exists_nat {n : ℕ} (p : ℕ) have hcard0 : ((Nat.card (Equiv.Perm (Fin n)) : ℂ)) ≠ 0 := by rw [Nat.card_eq_fintype_card] exact_mod_cast Fintype.card_ne_zero - haveI : Invertible ((Nat.card (Equiv.Perm (Fin n)) : ℂ)) := + 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) @@ -294,7 +295,7 @@ theorem diagramSchur_superPS_e_exists_nat {n : ℕ} (q : ℕ) have hcard0 : ((Nat.card (Equiv.Perm (Fin n)) : ℂ)) ≠ 0 := by rw [Nat.card_eq_fintype_card] exact_mod_cast Fintype.card_ne_zero - haveI : Invertible ((Nat.card (Equiv.Perm (Fin n)) : ℂ)) := + 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PieriPos.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PieriPos.lean index 27be0b2d94..5f1108c3f3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PieriPos.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PieriPos.lean @@ -150,7 +150,7 @@ theorem diagramSchur_smul_pow (mu : YoungDiagram) (t : ℕ → ℂ) (z : ℂ) : diagramSchur mu (fun c => z ^ c * t c) = z ^ mu.card * diagramSchur mu t := by - show diagramSchur (⟨mu, rfl⟩ : Shape mu.card).val + 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) @@ -203,12 +203,12 @@ theorem diagramSchur_graded_lin_indep {n : ℕ} if j = k then (∑ κ : Shape j, c j κ * diagramSchur κ.val t) else 0 from by by_cases hjk : j = k - · rw [if_pos hjk, if_pos hjk.symm, mul_one] - · rw [if_neg hjk, if_neg (fun hkj => hjk hkj.symm), mul_zero])] + · 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), - if_pos (Finset.mem_range.mpr (Nat.lt_succ_of_le hk))] at hcoeff + 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) @@ -336,7 +336,7 @@ noncomputable def stripDiagram {ℓ : ℕ} (r : Fin ℓ → ℕ) : 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, dif_pos h, YoungDiagram.mem_ofRowLens] + rw [stripDiagram, dite_eq_left h, YoungDiagram.mem_ofRowLens] constructor · rintro ⟨h1, h2⟩ have hc : c.1 < ℓ := by simpa using h1 @@ -537,8 +537,8 @@ private theorem sum_stripDiagram_graded {ℓ n : ℕ} rw [Finset.sum_filter] refine Finset.sum_congr rfl fun μ _ => ?_ by_cases hμ : p μ.val - · rw [if_pos hμ, if_pos hμ, one_mul] - · rw [if_neg hμ, if_neg hμ, zero_mul])] + · 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) @@ -684,7 +684,7 @@ theorem rowOp_blockTriangular (ℓ : ℕ) : /-- The row operation has determinant one. -/ theorem det_rowOp (ℓ : ℕ) : (rowOp ℓ).det = 1 := by - rw [Matrix.det_of_upperTriangular (rowOp_blockTriangular ℓ)] + rw [Matrix.det_of_isUpperTriangular (rowOp_blockTriangular ℓ)] refine Finset.prod_eq_one fun i _ => ?_ simp [rowOp] @@ -696,47 +696,47 @@ private theorem rowOp_mul_apply {ℓ : ℕ} else 0) := by rw [Matrix.mul_apply] by_cases h : (i : ℕ) + 1 < ℓ - · rw [dif_pos h] + · 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 [if_pos h1, if_pos h1, one_mul, - if_neg (fun he => by + · 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 [if_neg h1, if_neg h1] + · rw [ite_eq_right h1, ite_eq_right h1] by_cases h2 : (k : ℕ) = (i : ℕ) + 1 - · rw [if_pos h2, if_pos (Fin.ext h2), neg_one_mul, zero_add] - · rw [if_neg h2, - if_neg (fun hk => h2 (congrArg Fin.val hk)), + · 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), - if_pos (Finset.mem_univ i), + ite_eq_left (Finset.mem_univ i), Finset.sum_ite_eq' Finset.univ (⟨(i : ℕ) + 1, h⟩ : Fin ℓ) (fun k => -M k j), - if_pos (Finset.mem_univ _)] + ite_eq_left (Finset.mem_univ _)] ring - · rw [dif_neg h] + · 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 [if_pos h1, if_pos h1, one_mul] - · rw [if_neg h1, if_neg h1, - if_neg (fun h2 : (k : ℕ) = (i : ℕ) + 1 => + · 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), - if_pos (Finset.mem_univ i)] + ite_eq_left (Finset.mem_univ i)] ring /-! ### The horizontal Pieri determinant identity -/ @@ -806,8 +806,8 @@ theorem diagramSchur_add_one_row (lam : YoungDiagram) (t : ℕ → ℂ) : congr 1 ring by_cases h : (i : ℕ) + 1 < lam.rowLens.length - · rw [dif_pos h] - show newtonHZ (fun c => t c + superPS 1 0 c) + · 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 : ℤ) - @@ -818,7 +818,7 @@ theorem diagramSchur_add_one_row (lam : YoungDiagram) (t : ℕ → ℂ) : ((j : ℤ) - (i : ℤ)) from by push_cast; ring] rw [harg, hsum, hfix] ring - · rw [dif_neg h] + · 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)] @@ -826,7 +826,7 @@ theorem diagramSchur_add_one_row (lam : YoungDiagram) (t : ℕ → ℂ) : have hi := i.isLt push_cast omega - show newtonHZ (fun c => t c + superPS 1 0 c) + change newtonHZ (fun c => t c + superPS 1 0 c) ((lam.rowLen (i : ℕ) : ℤ) + (j : ℤ) - (i : ℤ)) - 0 = _ rw [harg, hsum, newtonHZ_neg _ _ hneg, hfix] ring @@ -848,7 +848,7 @@ theorem diagramSchur_add_one_row (lam : YoungDiagram) (t : ℕ → ℂ) : funext j rw [Finset.sum_apply] exact h2 i j - show Matrix.detRowAlternating + change Matrix.detRowAlternating (fun i : Fin lam.rowLens.length => (rowOp lam.rowLens.length * M) i) = _ rw [hrows] @@ -969,6 +969,49 @@ private theorem colStripVecs_anti {lam : YoungDiagram} : 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 @@ -999,7 +1042,7 @@ theorem diagramSchur_add_one_col (lam : YoungDiagram) (t : ℕ → ℂ) : funext i funext j rw [Finset.sum_apply] - show newtonHZ (fun c => t c + superPS 0 1 c) + 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 ≠ @@ -1015,7 +1058,7 @@ theorem diagramSchur_add_one_col (lam : YoungDiagram) (t : ℕ → ℂ) : (lam.rowLen (i : ℕ) : ℤ)} : Finset ℤ)), (Matrix.of fun i j : Fin lam.rowLens.length => newtonHZ t (r i + (j : ℤ) - (i : ℤ))).det := by - show Matrix.detRowAlternating + change Matrix.detRowAlternating (fun i : Fin lam.rowLens.length => M i) = _ rw [h2] exact (Matrix.detRowAlternating (n := Fin lam.rowLens.length) @@ -1026,45 +1069,7 @@ theorem diagramSchur_add_one_col (lam : YoungDiagram) (t : ℕ → ℂ) : (fun i => ({(lam.rowLen (i : ℕ) : ℤ) - 1, (lam.rowLen (i : ℕ) : ℤ)} : Finset ℤ)) -- non-monotone choices produce equal adjacent rows - have h4 : ∀ 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 - 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 - show 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 + 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 => @@ -1093,12 +1098,12 @@ theorem diagramSchur_add_one_col (lam : YoungDiagram) (t : ℕ → ℂ) : have hpos : 0 < lam.rowLen (i : ℕ) := rowLen_pos_of_lt_length lam i.isLt rw [Finset.mem_Icc] - show lam.rowLen (i : ℕ) - 1 ≤ (r i).toNat ∧ + 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 - show (r ⟨i + 1, hi⟩).toNat ≤ + change (r ⟨i + 1, hi⟩).toNat ≤ (r ⟨i, Nat.lt_of_succ_lt hi⟩).toNat omega · intro s hs @@ -1116,7 +1121,7 @@ theorem diagramSchur_add_one_col (lam : YoungDiagram) (t : ℕ → ℂ) : omega · intro i hi have := hgood i hi - show ((s ⟨i + 1, hi⟩ : ℕ) : ℤ) ≤ + change ((s ⟨i + 1, hi⟩ : ℕ) : ℤ) ≤ ((s ⟨i, Nat.lt_of_succ_lt hi⟩ : ℕ) : ℤ) omega · intro r hr @@ -1126,11 +1131,11 @@ theorem diagramSchur_add_one_col (lam : YoungDiagram) (t : ℕ → ℂ) : rw [Finset.mem_insert, Finset.mem_singleton] at hm have hpos : 0 < lam.rowLen (i : ℕ) := rowLen_pos_of_lt_length lam i.isLt - show ((r i).toNat : ℤ) = r i + change ((r i).toNat : ℤ) = r i omega · intro s _ funext i - show ((s i : ℕ) : ℤ).toNat = s i + change ((s i : ℕ) : ℤ).toNat = s i omega · intro r hr have hgood := (Finset.mem_filter.mp hr).2 @@ -1207,10 +1212,10 @@ private theorem sum_shape_superPS_row {b : ℕ} (G : Shape b → ℂ) : rw [diagramSchur_superPS_row ν.val]] rw [Finset.sum_eq_single (rowShape b) (fun ν _ hne => by - rw [if_neg (fun hle => hne (shape_eq_rowShape ν hle)), + rw [ite_eq_right (fun hle => hne (shape_eq_rowShape ν hle)), mul_zero]) (fun h => absurd (Finset.mem_univ _) h)] - rw [if_pos (rowShape_colLen b), mul_one] + 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. -/ @@ -1221,10 +1226,10 @@ private theorem sum_shape_superPS_col {b : ℕ} (G : Shape b → ℂ) : rw [diagramSchur_superPS_col ν.val]] rw [Finset.sum_eq_single (colShape b) (fun ν _ hne => by - rw [if_neg (fun hle => hne (shape_eq_colShape ν hle)), + rw [ite_eq_right (fun hle => hne (shape_eq_colShape ν hle)), mul_zero]) (fun h => absurd (Finset.mem_univ _) h)] - rw [if_pos (colShape_rowLen_zero_le b), mul_one] + rw [ite_eq_left (colShape_rowLen_zero_le b), mul_one] /-- Transport of induction multiplicities along an equality of the second size. -/ @@ -1277,7 +1282,7 @@ private theorem diagramSchur_add_superPS_row_expand {n : ℕ} refine Finset.sum_congr rfl fun κ _ => ?_ have h1 := Finset.mem_antidiagonal.mp ab.2 have h2 := lam.prop - rw [dif_pos (show ab.1.1 ≤ n by omega)] + 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 κ _ _ @@ -1325,7 +1330,7 @@ private theorem diagramSchur_add_superPS_col_expand {n : ℕ} refine Finset.sum_congr rfl fun κ _ => ?_ have h1 := Finset.mem_antidiagonal.mp ab.2 have h2 := lam.prop - rw [dif_pos (show ab.1.1 ≤ n by omega)] + 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 κ _ _ @@ -1398,7 +1403,7 @@ private theorem diagramSchur_superPS_pos_rows : 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 ?_ - show lam.rowLens.length ≤ p + 1 + change lam.rowLens.length ≤ p + 1 have hl := YoungDiagram.length_rowLens (μ := lam) omega · exact stripDiagram_rowLen_le hanti₀ hp @@ -1413,9 +1418,9 @@ private theorem diagramSchur_superPS_pos_rows : · intro k _ refine exists_nat_sum _ _ fun μ _ => ?_ by_cases hμ : IsHStrip lam μ.val - · rw [if_pos hμ, one_mul] + · rw [ite_eq_left hμ, one_mul] exact diagramSchur_superPS_exists_nat p 0 μ.val - · rw [if_neg hμ, zero_mul] + · 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)) @@ -1424,15 +1429,15 @@ private theorem diagramSchur_superPS_pos_rows : (Finset.mem_univ _) ?_ · intro μ _ by_cases hμ : IsHStrip lam μ.val - · rw [if_pos hμ, one_mul] + · rw [ite_eq_left hμ, one_mul] exact diagramSchur_superPS_exists_nat p 0 μ.val - · rw [if_neg hμ, zero_mul] + · rw [ite_eq_right hμ, zero_mul] exact ⟨0, by simp⟩ · refine ⟨m₀, hm₀, ?_⟩ - show (if IsHStrip lam (stripDiagram r₀) then (1 : ℂ) + change (if IsHStrip lam (stripDiagram r₀) then (1 : ℂ) else 0) * diagramSchur (stripDiagram r₀) (superPS p 0) = (m₀ : ℂ) - rw [if_pos hstrip, one_mul, hval₀] + 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 @@ -1464,7 +1469,7 @@ theorem diagramSchur_superPS_pos {p q : ℕ} (lam : YoungDiagram) r₁ j ≤ r₁ i := by intro i j hij have h := lam.rowLen_anti (i : ℕ) (j : ℕ) hij - show (if q < lam.rowLen (j : ℕ) then lam.rowLen (j : ℕ) - 1 + 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 : ℕ)) @@ -1474,7 +1479,7 @@ theorem diagramSchur_superPS_pos {p q : ℕ} (lam : YoungDiagram) · 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⟩] - show (if q < lam.rowLen i then lam.rowLen i - 1 + 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] @@ -1482,7 +1487,7 @@ theorem diagramSchur_superPS_pos {p q : ℕ} (lam : YoungDiagram) · intro i rcases Nat.lt_or_ge i lam.rowLens.length with hi | hi · rw [stripDiagram_rowLen_lt hanti₁ ⟨i, hi⟩] - show lam.rowLen i ≤ (if q < lam.rowLen i then + 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, @@ -1492,7 +1497,7 @@ theorem diagramSchur_superPS_pos {p q : ℕ} (lam : YoungDiagram) 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⟩] - show (if q < lam.rowLen p then lam.rowLen p - 1 + 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] @@ -1505,9 +1510,9 @@ theorem diagramSchur_superPS_pos {p q : ℕ} (lam : YoungDiagram) · intro k _ refine exists_nat_sum _ _ fun μ _ => ?_ by_cases hμ : IsVStrip lam μ.val - · rw [if_pos hμ, one_mul] + · rw [ite_eq_left hμ, one_mul] exact diagramSchur_superPS_exists_nat p q μ.val - · rw [if_neg hμ, zero_mul] + · 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)) @@ -1516,14 +1521,14 @@ theorem diagramSchur_superPS_pos {p q : ℕ} (lam : YoungDiagram) (Finset.mem_univ _) ?_ · intro μ _ by_cases hμ : IsVStrip lam μ.val - · rw [if_pos hμ, one_mul] + · rw [ite_eq_left hμ, one_mul] exact diagramSchur_superPS_exists_nat p q μ.val - · rw [if_neg hμ, zero_mul] + · rw [ite_eq_right hμ, zero_mul] exact ⟨0, by simp⟩ · refine ⟨m₀, hm₀, ?_⟩ - show (if IsVStrip lam (stripDiagram r₁) then (1 : ℂ) + change (if IsVStrip lam (stripDiagram r₁) then (1 : ℂ) else 0) * diagramSchur (stripDiagram r₁) (superPS p q) = (m₀ : ℂ) - rw [if_pos hstrip, one_mul, hval₀] + rw [ite_eq_left hstrip, one_mul, hval₀] end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointBaseChange.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointBaseChange.lean index 9d04dc3aa5..cd6ccd6bfa 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointBaseChange.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointBaseChange.lean @@ -213,7 +213,7 @@ instance finiteDimensional_pointMod_odd (P : SuperPoint S) : one-dimensional. -/ theorem finrank_pointMod_even (P : SuperPoint S) : Module.finrank ℂ (pointMod P : S.Mod.{u, u, u, u}).even = 1 := by - show Module.finrank ℂ (ULift.{u} ℂ) = 1 + change Module.finrank ℂ (ULift.{u} ℂ) = 1 rw [LinearEquiv.finrank_eq (ULift.moduleEquiv (R := ℂ) (M := ℂ)), Module.finrank_self] @@ -362,8 +362,7 @@ 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}) - [FiniteDimensional ℂ (M.tensor (pointMod P)).even] - [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] : + : SuperVect where even := Fin (Module.finrank ℂ (M.tensor (pointMod P)).even) → ℂ odd := Fin (Module.finrank ℂ (M.tensor (pointMod P)).odd) → ℂ @@ -441,7 +440,7 @@ theorem finrank_toSuperVect_even_of_free (P : SuperPoint S) [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] : Module.finrank ℂ (toSuperVect P M).even = p := by rw [← finrank_even_of_free P p q M e] - show Module.finrank ℂ + change Module.finrank ℂ (Fin (Module.finrank ℂ (M.tensor (pointMod P)).even) → ℂ) = _ rw [Module.finrank_fin_fun ℂ] @@ -456,7 +455,7 @@ theorem finrank_toSuperVect_odd_of_free (P : SuperPoint S) [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] : Module.finrank ℂ (toSuperVect P M).odd = q := by rw [← finrank_odd_of_free P p q M e] - show Module.finrank ℂ + change Module.finrank ℂ (Fin (Module.finrank ℂ (M.tensor (pointMod P)).odd) → ℂ) = _ rw [Module.finrank_fin_fun ℂ] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointFibre.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointFibre.lean index 4787562fad..52445b7977 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointFibre.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointFibre.lean @@ -231,12 +231,12 @@ 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 => ?_ - · show (toSuperVectEvenEquiv P M) + · 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 - · show (toSuperVectOddEquiv P M) + · change (toSuperVectOddEquiv P M) (((tensorRightFunctor (pointMod P)).map (𝟙 M)).oddMap ((toSuperVectOddEquiv P M).symm x)) = x rw [CategoryTheory.Functor.map_id] @@ -253,22 +253,22 @@ theorem superVectHom_comp [FiniteDimensional ℂ (M.tensor (pointMod P)).even] (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 => ?_ - · show (toSuperVectEvenEquiv P Q) + · change (toSuperVectEvenEquiv P Q) (((tensorRightFunctor (pointMod P)).map (u ≫ v)).evenMap ((toSuperVectEvenEquiv P M).symm x)) = _ rw [CategoryTheory.Functor.map_comp] - show _ = (toSuperVectEvenEquiv P Q) + 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 - · show (toSuperVectOddEquiv P Q) + · change (toSuperVectOddEquiv P Q) (((tensorRightFunctor (pointMod P)).map (u ≫ v)).oddMap ((toSuperVectOddEquiv P M).symm x)) = _ rw [CategoryTheory.Functor.map_comp] - show _ = (toSuperVectOddEquiv P Q) + change _ = (toSuperVectOddEquiv P Q) (((tensorRightFunctor (pointMod P)).map v).oddMap ((toSuperVectOddEquiv P N).symm ((toSuperVectOddEquiv P N) (((tensorRightFunctor (pointMod P)).map u).oddMap @@ -284,20 +284,20 @@ theorem superVectHom_add [FiniteDimensional ℂ (M.tensor (pointMod P)).even] (u v : M ⟶ N) : superVectHom P (u + v) = superVectHom P u + superVectHom P v := by refine SuperVect.hom_ext ?_ ?_ <;> refine LinearMap.ext fun x => ?_ - · show (toSuperVectEvenEquiv P N) + · change (toSuperVectEvenEquiv P N) (((tensorRightFunctor (pointMod P)).map (u + v)).evenMap ((toSuperVectEvenEquiv P M).symm x)) = _ rw [CategoryTheory.Functor.map_add] - show (toSuperVectEvenEquiv P N) + change (toSuperVectEvenEquiv P N) ((((tensorRightFunctor (pointMod P)).map u).evenMap + ((tensorRightFunctor (pointMod P)).map v).evenMap) ((toSuperVectEvenEquiv P M).symm x)) = _ exact map_add _ _ _ - · show (toSuperVectOddEquiv P N) + · change (toSuperVectOddEquiv P N) (((tensorRightFunctor (pointMod P)).map (u + v)).oddMap ((toSuperVectOddEquiv P M).symm x)) = _ rw [CategoryTheory.Functor.map_add] - show (toSuperVectOddEquiv P N) + change (toSuperVectOddEquiv P N) ((((tensorRightFunctor (pointMod P)).map u).oddMap + ((tensorRightFunctor (pointMod P)).map v).oddMap) ((toSuperVectOddEquiv P M).symm x)) = _ @@ -311,19 +311,19 @@ theorem superVectHom_smul [FiniteDimensional ℂ (M.tensor (pointMod P)).even] (c : ℂ) (u : M ⟶ N) : superVectHom P (c • u) = c • superVectHom P u := by refine SuperVect.hom_ext ?_ ?_ <;> refine LinearMap.ext fun x => ?_ - · show (toSuperVectEvenEquiv P N) + · change (toSuperVectEvenEquiv P N) (((tensorRightFunctor (pointMod P)).map (c • u)).evenMap ((toSuperVectEvenEquiv P M).symm x)) = _ rw [CategoryTheory.Functor.map_smul] - show (toSuperVectEvenEquiv P N) + change (toSuperVectEvenEquiv P N) ((c • ((tensorRightFunctor (pointMod P)).map u).evenMap) ((toSuperVectEvenEquiv P M).symm x)) = _ exact map_smul (toSuperVectEvenEquiv P N) c _ - · show (toSuperVectOddEquiv P N) + · change (toSuperVectOddEquiv P N) (((tensorRightFunctor (pointMod P)).map (c • u)).oddMap ((toSuperVectOddEquiv P M).symm x)) = _ rw [CategoryTheory.Functor.map_smul] - show (toSuperVectOddEquiv P N) + change (toSuperVectOddEquiv P N) ((c • ((tensorRightFunctor (pointMod P)).map u).oddMap) ((toSuperVectOddEquiv P M).symm x)) = _ exact map_smul (toSuperVectOddEquiv P N) c _ @@ -343,16 +343,16 @@ noncomputable def superVectFunctor (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) (hE X) (hO X) + 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 - show @superVectHom _ P _ _ (hE X) (hO X) (hE X) (hO X) + 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 - show @superVectHom _ P _ _ (hE X) (hO X) (hE Z) (hO Z) + change @superVectHom _ P _ _ (hE X) (hO X) (hE Z) (hO Z) (G.map (f ≫ g)) = _ rw [CategoryTheory.Functor.map_comp] exact superVectHom_comp P _ _ @@ -363,7 +363,7 @@ noncomputable def superVectFunctor (hO : ∀ X, FiniteDimensional ℂ ((G.obj X).tensor (pointMod P)).odd) (X : E) : (superVectFunctor P G hE hO).obj X = - @toSuperVect _ P (G.obj X) (hE X) (hO X) := rfl + toSuperVect P (G.obj X) := rfl @[simp] theorem superVectFunctor_map [Category.{v₂} E] (G : E ⥤ S.Mod.{u, u, u, u}) @@ -384,7 +384,7 @@ instance superVectFunctor_additive [Preadditive E] [G.Additive] : (superVectFunctor P G hE hO).Additive where map_add {X Y f g} := by - show @superVectHom _ P _ _ (hE X) (hO X) (hE Y) (hO Y) + change @superVectHom _ P _ _ (hE X) (hO X) (hE Y) (hO Y) (G.map (f + g)) = _ rw [CategoryTheory.Functor.map_add] exact superVectHom_add P _ _ @@ -394,10 +394,10 @@ instance superVectFunctor_linear [Category.{v₂} E] (G : E ⥤ S.Mod.{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.Additive] [G.Linear ℂ] : + [CategoryTheory.Linear ℂ E] [G.Linear ℂ] : (superVectFunctor P G hE hO).Linear ℂ where map_smul {X Y} f c := by - show @superVectHom _ P _ _ (hE X) (hO X) (hE Y) (hO Y) + change @superVectHom _ P _ _ (hE X) (hO X) (hE Y) (hO Y) (G.map (c • f)) = _ rw [CategoryTheory.Functor.map_smul] exact superVectHom_smul P _ _ @@ -675,7 +675,7 @@ theorem id_eq_zero_of_deligneFibre_id_eq_zero (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 - haveI : (indOf (C := C)).Additive := indOf_additive + have : (indOf (C := C)).Additive := indOf_additive obtain ⟨p, q, ⟨e⟩⟩ := hsp Z have hide : (LinearMap.id : ((deligneFibre L 𝔸 hsp P).obj Z).even →ₗ[ℂ] @@ -685,12 +685,12 @@ theorem id_eq_zero_of_deligneFibre_id_eq_zero ((deligneFibre L 𝔸 hsp P).obj Z).odd →ₗ[ℂ] ((deligneFibre L 𝔸 hsp P).obj Z).odd) = 0 := congrArg SuperVect.Hom.oddMap hz - haveI : Subsingleton ((deligneFibre L 𝔸 hsp P).obj Z).even := + 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]⟩ - haveI : Subsingleton ((deligneFibre L 𝔸 hsp P).obj Z).odd := + 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 @@ -755,7 +755,7 @@ theorem deligneFibre_faithful 𝟙 (freeMod 𝔸 ((T.map (indOf : C ⥤ Ind C)).X₃))) (P : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) : (deligneFibre L 𝔸 hsp P).Faithful := by - haveI : (deligneFibre L 𝔸 hsp P).PreservesHomology := + have : (deligneFibre L 𝔸 hsp P).PreservesHomology := superVectFunctor_preservesHomology P _ _ _ (indFibre_nonempty_splitting L 𝔸 hsec) refine ⟨fun {X Y} f g hfg => ?_⟩ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Calculus.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Calculus.lean index 2360c7a44b..de6ed4a7b1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Calculus.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Calculus.lean @@ -136,7 +136,7 @@ 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 - show X.actEE (r • S.one) z = r • z + 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 @@ -145,7 +145,7 @@ 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 - show X.actEO (r • S.one) z = r • z + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean index 92af9d4819..1bb1e2e0c5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean @@ -58,9 +58,7 @@ attribute [local irreducible] superVectMu variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) (M N Q : S.Mod.{u, u, u, u}) -/-- **Associativity of the monoidal comparison.** -/ -@[reassoc] -theorem superVectMu_associativity +private theorem superVectMu_associativity_evenMap [FiniteDimensional ℂ (M.tensor (pointMod P)).even] [FiniteDimensional ℂ (M.tensor (pointMod P)).odd] [FiniteDimensional ℂ (N.tensor (pointMod P)).even] @@ -75,18 +73,15 @@ theorem superVectMu_associativity [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 N ▷ toSuperVect P Q) ≫ superVectMu P (M.tensor N) Q ≫ - superVectHom P (α_ M N Q).hom = - (α_ (toSuperVect P M) (toSuperVect P N) + 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) := by - refine SuperVect.hom_ext - (superVectTripleEven_ext (fun a b c => ?_) (fun a b c => ?_) - (fun a b c => ?_) (fun a b c => ?_)) - (superVectTripleOdd_ext (fun a b c => ?_) (fun a b c => ?_) - (fun a b c => ?_) (fun a b c => ?_)) + 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)) @@ -100,20 +95,15 @@ theorem superVectMu_associativity 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, svComp_oddMap_apply, - svWhiskerRight_evenMap_inl, svWhiskerRight_evenMap_inr, - svWhiskerRight_oddMap_inl, svWhiskerRight_oddMap_inr, - svWhiskerLeft_evenMap_inl, svWhiskerLeft_evenMap_inr, - svWhiskerLeft_oddMap_inl, svWhiskerLeft_oddMap_inr, - svAssoc_evenMap_ee, svAssoc_evenMap_oo, svAssoc_evenMap_eo, - svAssoc_evenMap_oe, svAssoc_oddMap_ee, svAssoc_oddMap_oo, - svAssoc_oddMap_eo, svAssoc_oddMap_oe, - superVectMu_evenMap_ee, superVectMu_evenMap_oo, - superVectMu_oddMap_eo, superVectMu_oddMap_oe, - superVectHom_evenMap_apply, superVectHom_oddMap_apply, - LinearEquiv.symm_apply_apply] - rw [key, superVectMu_evenMap_ee, + 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 @@ -128,20 +118,16 @@ theorem superVectMu_associativity 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, svComp_oddMap_apply, - svWhiskerRight_evenMap_inl, svWhiskerRight_evenMap_inr, - svWhiskerRight_oddMap_inl, svWhiskerRight_oddMap_inr, - svWhiskerLeft_evenMap_inl, svWhiskerLeft_evenMap_inr, - svWhiskerLeft_oddMap_inl, svWhiskerLeft_oddMap_inr, - svAssoc_evenMap_ee, svAssoc_evenMap_oo, svAssoc_evenMap_eo, - svAssoc_evenMap_oe, svAssoc_oddMap_ee, svAssoc_oddMap_oo, - svAssoc_oddMap_eo, svAssoc_oddMap_oe, + simp only [svComp_evenMap_apply, + svWhiskerRight_evenMap_inl, + svWhiskerLeft_evenMap_inr, + svAssoc_evenMap_oo, + superVectMu_evenMap_ee, superVectMu_evenMap_oo, - superVectMu_oddMap_eo, superVectMu_oddMap_oe, - superVectHom_evenMap_apply, superVectHom_oddMap_apply, - LinearEquiv.symm_apply_apply] - rw [key, 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 @@ -156,17 +142,14 @@ theorem superVectMu_associativity 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, svComp_oddMap_apply, - svWhiskerRight_evenMap_inl, svWhiskerRight_evenMap_inr, - svWhiskerRight_oddMap_inl, svWhiskerRight_oddMap_inr, - svWhiskerLeft_evenMap_inl, svWhiskerLeft_evenMap_inr, - svWhiskerLeft_oddMap_inl, svWhiskerLeft_oddMap_inr, - svAssoc_evenMap_ee, svAssoc_evenMap_oo, svAssoc_evenMap_eo, - svAssoc_evenMap_oe, svAssoc_oddMap_ee, svAssoc_oddMap_oo, - svAssoc_oddMap_eo, svAssoc_oddMap_oe, - superVectMu_evenMap_ee, superVectMu_evenMap_oo, - superVectMu_oddMap_eo, superVectMu_oddMap_oe, - superVectHom_evenMap_apply, superVectHom_oddMap_apply, + 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] @@ -184,21 +167,42 @@ theorem superVectMu_associativity 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, svComp_oddMap_apply, - svWhiskerRight_evenMap_inl, svWhiskerRight_evenMap_inr, - svWhiskerRight_oddMap_inl, svWhiskerRight_oddMap_inr, - svWhiskerLeft_evenMap_inl, svWhiskerLeft_evenMap_inr, - svWhiskerLeft_oddMap_inl, svWhiskerLeft_oddMap_inr, - svAssoc_evenMap_ee, svAssoc_evenMap_oo, svAssoc_evenMap_eo, - svAssoc_evenMap_oe, svAssoc_oddMap_ee, svAssoc_oddMap_oo, - svAssoc_oddMap_eo, svAssoc_oddMap_oe, - superVectMu_evenMap_ee, superVectMu_evenMap_oo, + 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, superVectHom_oddMap_apply, - LinearEquiv.symm_apply_apply] - rw [key, superVectMu_evenMap_oo, + 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)) @@ -212,20 +216,15 @@ theorem superVectMu_associativity rw [whiskerRight_oddMap_tmulEO, modAssoc_oddMap_ee, whiskerLeft_oddMap_tmulEO (pointBaseMu P N Q) (M.tensor (pointMod P))] at key - simp only [svComp_evenMap_apply, svComp_oddMap_apply, - svWhiskerRight_evenMap_inl, svWhiskerRight_evenMap_inr, - svWhiskerRight_oddMap_inl, svWhiskerRight_oddMap_inr, - svWhiskerLeft_evenMap_inl, svWhiskerLeft_evenMap_inr, - svWhiskerLeft_oddMap_inl, svWhiskerLeft_oddMap_inr, - svAssoc_evenMap_ee, svAssoc_evenMap_oo, svAssoc_evenMap_eo, - svAssoc_evenMap_oe, svAssoc_oddMap_ee, svAssoc_oddMap_oo, - svAssoc_oddMap_eo, svAssoc_oddMap_oe, - superVectMu_evenMap_ee, superVectMu_evenMap_oo, - superVectMu_oddMap_eo, superVectMu_oddMap_oe, - superVectHom_evenMap_apply, superVectHom_oddMap_apply, - LinearEquiv.symm_apply_apply] - rw [key, superVectMu_oddMap_eo, + 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 @@ -240,17 +239,13 @@ theorem superVectMu_associativity rw [whiskerRight_oddMap_tmulEO, modAssoc_oddMap_oo, whiskerLeft_oddMap_tmulOE (pointBaseMu P N Q) (M.tensor (pointMod P))] at key - simp only [svComp_evenMap_apply, svComp_oddMap_apply, - svWhiskerRight_evenMap_inl, svWhiskerRight_evenMap_inr, - svWhiskerRight_oddMap_inl, svWhiskerRight_oddMap_inr, - svWhiskerLeft_evenMap_inl, svWhiskerLeft_evenMap_inr, - svWhiskerLeft_oddMap_inl, svWhiskerLeft_oddMap_inr, - svAssoc_evenMap_ee, svAssoc_evenMap_oo, svAssoc_evenMap_eo, - svAssoc_evenMap_oe, svAssoc_oddMap_ee, svAssoc_oddMap_oo, - svAssoc_oddMap_eo, svAssoc_oddMap_oe, - superVectMu_evenMap_ee, superVectMu_evenMap_oo, - superVectMu_oddMap_eo, superVectMu_oddMap_oe, - superVectHom_evenMap_apply, superVectHom_oddMap_apply, + 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] @@ -268,20 +263,15 @@ theorem superVectMu_associativity rw [whiskerRight_oddMap_tmulOE, modAssoc_oddMap_eo, whiskerLeft_oddMap_tmulEO (pointBaseMu P N Q) (M.tensor (pointMod P))] at key - simp only [svComp_evenMap_apply, svComp_oddMap_apply, - svWhiskerRight_evenMap_inl, svWhiskerRight_evenMap_inr, - svWhiskerRight_oddMap_inl, svWhiskerRight_oddMap_inr, - svWhiskerLeft_evenMap_inl, svWhiskerLeft_evenMap_inr, - svWhiskerLeft_oddMap_inl, svWhiskerLeft_oddMap_inr, - svAssoc_evenMap_ee, svAssoc_evenMap_oo, svAssoc_evenMap_eo, - svAssoc_evenMap_oe, svAssoc_oddMap_ee, svAssoc_oddMap_oo, - svAssoc_oddMap_eo, svAssoc_oddMap_oe, - superVectMu_evenMap_ee, superVectMu_evenMap_oo, + simp only [ svComp_oddMap_apply, + svWhiskerRight_oddMap_inr, + svWhiskerLeft_oddMap_inl, + + svAssoc_oddMap_eo, superVectMu_oddMap_eo, superVectMu_oddMap_oe, - superVectHom_evenMap_apply, superVectHom_oddMap_apply, - LinearEquiv.symm_apply_apply] - rw [key, superVectMu_oddMap_eo, + superVectHom_oddMap_apply, LinearEquiv.symm_apply_apply] + rw [key] rfl · have key := LinearMap.congr_fun (congrArg SuperCommAlgebra.Mod.Hom.oddMap @@ -296,22 +286,45 @@ theorem superVectMu_associativity rw [whiskerRight_oddMap_tmulOE, modAssoc_oddMap_oe, whiskerLeft_oddMap_tmulOE (pointBaseMu P N Q) (M.tensor (pointMod P))] at key - simp only [svComp_evenMap_apply, svComp_oddMap_apply, - svWhiskerRight_evenMap_inl, svWhiskerRight_evenMap_inr, - svWhiskerRight_oddMap_inl, svWhiskerRight_oddMap_inr, - svWhiskerLeft_evenMap_inl, svWhiskerLeft_evenMap_inr, - svWhiskerLeft_oddMap_inl, svWhiskerLeft_oddMap_inr, - svAssoc_evenMap_ee, svAssoc_evenMap_oo, svAssoc_evenMap_eo, - svAssoc_evenMap_oe, svAssoc_oddMap_ee, svAssoc_oddMap_oo, - svAssoc_oddMap_eo, svAssoc_oddMap_oe, - superVectMu_evenMap_ee, superVectMu_evenMap_oo, - superVectMu_oddMap_eo, superVectMu_oddMap_oe, - superVectHom_evenMap_apply, superVectHom_oddMap_apply, - LinearEquiv.symm_apply_apply] - rw [key, superVectMu_oddMap_oe, + 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 -/ @@ -524,7 +537,7 @@ variable {S : SuperCommAlgebra.{u, u}} (P : SuperPoint S) theorem pointEven_eq_smul_one (a : (pointMod P : S.Mod.{u, u, u, u}).even) : a = a.down • pointOne P := ULift.ext _ _ (by - show a.down = a.down * 1 + change a.down = a.down * 1 rw [mul_one]) /-- The unit of the residue module is idempotent. -/ @@ -532,7 +545,7 @@ 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 - show (1 : ℂ) * 1 = 1 + change (1 : ℂ) * 1 = 1 rw [one_mul]) variable {M N} @@ -565,7 +578,7 @@ theorem superVectMuEvenRaw_baseNuEven (w : ((M.tensor N).tensor (pointMod P) : (pointMod P) ((superVectMuEvenRaw P M N).comp (baseNuEven P M N)) LinearMap.id (fun t a => ?_) (fun t v => ?_)) w - · show superVectMuEvenRaw P M N + · 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] @@ -574,24 +587,24 @@ theorem superVectMuEvenRaw_baseNuEven (w : ((M.tensor N).tensor (pointMod P) : ((baseNuInnerEven P M N).flip a)) ((tmulEE (M.tensor N) (pointMod P)).flip a) (fun m n => ?_) (fun m n => ?_)) t - · show superVectMuEvenRaw P M N (baseNuFee P M N m n a) = _ + · change superVectMuEvenRaw P M N (baseNuFee P M N m n a) = _ rw [baseNuFee_apply, map_smul] - show a.down • (pointBaseMu P M N).evenMap + 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 - · show superVectMuEvenRaw P M N (baseNuFoo P M N m n a) = _ + · change superVectMuEvenRaw P M N (baseNuFoo P M N m n a) = _ rw [baseNuFoo_apply, map_smul] - show a.down • (pointBaseMu P M N).evenMap + 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] - show superVectMuEvenRaw P M N (baseNuEven P M N 0) = 0 + change superVectMuEvenRaw P M N (baseNuEven P M N 0) = 0 rw [map_zero, map_zero] /-- **The comparison undoes the inverse**, in odd degree. -/ @@ -603,9 +616,9 @@ theorem superVectMuOddRaw_baseNuOdd (w : ((M.tensor N).tensor (pointMod P) : (baseNuOdd P M N)) LinearMap.id (fun t v => ?_) (fun t a => ?_)) w · rw [pointMod_odd_eq_zero P v, map_zero] - show superVectMuOddRaw P M N (baseNuOdd P M N 0) = 0 + change superVectMuOddRaw P M N (baseNuOdd P M N 0) = 0 rw [map_zero, map_zero] - · show superVectMuOddRaw P M N + · 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] @@ -614,17 +627,17 @@ theorem superVectMuOddRaw_baseNuOdd (w : ((M.tensor N).tensor (pointMod P) : ((baseNuInnerOdd P M N).flip a)) ((tmulOE (M.tensor N) (pointMod P)).flip a) (fun m n => ?_) (fun m n => ?_)) t - · show superVectMuOddRaw P M N (baseNuFeo P M N m n a) = _ + · change superVectMuOddRaw P M N (baseNuFeo P M N m n a) = _ rw [baseNuFeo_apply, map_smul] - show a.down • (pointBaseMu P M N).oddMap + 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 - · show superVectMuOddRaw P M N (baseNuFoe P M N m n a) = _ + · change superVectMuOddRaw P M N (baseNuFoe P M N m n a) = _ rw [baseNuFoe_apply, map_smul] - show a.down • (pointBaseMu P M N).oddMap + 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))) = _ @@ -669,14 +682,14 @@ theorem baseNuEven_muRaw_inl : (fun m v => ?_) · refine liftEven_unique N (pointMod P) _ _ (fun n b => ?_) (fun n w => ?_) - · show baseNuEven P M N ((pointBaseMu P M N).evenMap + · 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] - show (a.down * b.down) • _ = _ + 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] @@ -698,14 +711,14 @@ theorem baseNuEven_muRaw_inr : · 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] - · show baseNuEven P M N ((pointBaseMu P M N).evenMap + · 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] - show (a.down * b.down) • _ = _ + change (a.down * b.down) • _ = _ rw [tmulOE_point_eq_smul P m a, tmulOE_point_eq_smul P n b] exact smulPairInr _ _ _ _ @@ -724,14 +737,14 @@ theorem baseNuOdd_muRaw_inl : · 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] - · show baseNuOdd P M N ((pointBaseMu P M N).oddMap + · 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] - show (a.down * b.down) • _ = _ + 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] @@ -751,14 +764,14 @@ theorem baseNuOdd_muRaw_inr : · 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 => ?_) - · show baseNuOdd P M N ((pointBaseMu P M N).oddMap + · 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] - show (a.down * b.down) • _ = _ + 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] @@ -963,23 +976,23 @@ theorem unitTensorPoint_superVectEpsRaw (c : ℂ) : 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 - show (SuperCommAlgebra.Mod.tensorHom (𝟙 S.unitMod) + 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] - show tmulEE (S.unitMod : S.Mod.{u, u, u, u}) (pointMod P) + 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 - show (leftUnitorHom (pointMod P)).evenMap + change (leftUnitorHom (pointMod P)).evenMap ((pointBaseEps P).evenMap (c • S.one)) = _ rw [h1, leftUnitorHom_evenMap_tmulEE] refine ULift.ext _ _ ?_ - show P.chi (c • S.one) * 1 = c + change P.chi (c • S.one) * 1 = c rw [mul_one, map_smul] - show c * P.chi 1 = c + change c * P.chi 1 = c rw [map_one, mul_one] /-- **The raw unit comparison is bijective.** -/ @@ -1036,7 +1049,7 @@ theorem superVectEps_oddMap_bijective [FiniteDimensional ℂ ((S.unitMod : S.Mod.{u, u, u, u}).tensor (pointMod P)).odd] : Function.Bijective (superVectEps P).oddMap := by - haveI : Subsingleton (𝟙_ SuperVect).odd := + have : Subsingleton (𝟙_ SuperVect).odd := (inferInstance : Subsingleton PUnit.{1}) exact ⟨fun _ _ _ => Subsingleton.elim _ _, fun y => ⟨0, Subsingleton.elim _ y⟩⟩ @@ -1092,7 +1105,7 @@ theorem superVectMu_left_unitality (superVectEps P ▷ toSuperVect P M) ≫ superVectMu P S.unitMod M ≫ superVectHom P (λ_ M).hom := by - haveI : Subsingleton (𝟙_ SuperVect).odd := + have : Subsingleton (𝟙_ SuperVect).odd := (inferInstance : Subsingleton PUnit.{1}) refine SuperVect.hom_ext (superVectPairEven_ext (fun r x => ?_) (fun u y => ?_)) @@ -1148,7 +1161,7 @@ theorem superVectMu_right_unitality (toSuperVect P M ◁ superVectEps P) ≫ superVectMu P M S.unitMod ≫ superVectHom P (ρ_ M).hom := by - haveI : Subsingleton (𝟙_ SuperVect).odd := + have : Subsingleton (𝟙_ SuperVect).odd := (inferInstance : Subsingleton PUnit.{1}) refine SuperVect.hom_ext (superVectPairEven_ext (fun x r => ?_) (fun y u => ?_)) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Comparison.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Comparison.lean index a1b4786b2f..c26531d5ed 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Comparison.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Comparison.lean @@ -81,10 +81,10 @@ noncomputable def pointScale (X : Type u) [AddCommGroup X] toFun x := LinearMap.smulRight (ULift.moduleEquiv (R := ℂ) (M := ℂ)).toLinearMap x map_add' x y := LinearMap.ext fun a => by - show a.down • (x + y) = a.down • x + a.down • y + change a.down • (x + y) = a.down • x + a.down • y exact smul_add _ _ _ map_smul' c x := LinearMap.ext fun a => by - show a.down • (c • x) = c • (a.down • x) + change a.down • (c • x) = c • (a.down • x) rw [smul_comm] /-- Scaling by a residue class, evaluated. -/ @@ -103,7 +103,7 @@ theorem tmulEE_actEE_pointOne (b : S.even) (m : M.even) : 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 - show P.chi b * 1 = P.chi b * 1 + change P.chi b * 1 = P.chi b * 1 rfl) rw [h, map_smul] @@ -115,7 +115,7 @@ theorem tmulOE_actEO_pointOne (b : S.even) (m : M.odd) : 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 - show P.chi b * 1 = P.chi b * 1 + change P.chi b * 1 = P.chi b * 1 rfl) rw [h, map_smul] @@ -188,11 +188,11 @@ theorem gradedTensorEven_naturality {A' B' : S.Mod.{u, u, u, u}} (TensorProduct.map uu.oddMap vv.oddMap)) := by refine LinearMap.prod_ext (TensorProduct.ext' fun x y => ?_) (TensorProduct.ext' fun x y => ?_) - · show (SuperCommAlgebra.Mod.tensorHom uu vv).evenMap + · change (SuperCommAlgebra.Mod.tensorHom uu vv).evenMap (tmulEE A B x y) = _ rw [tensorHom_evenMap_tmulEE] rfl - · show (SuperCommAlgebra.Mod.tensorHom uu vv).evenMap + · change (SuperCommAlgebra.Mod.tensorHom uu vv).evenMap (tmulOO A B x y) = _ rw [tensorHom_evenMap_tmulOO] rfl @@ -208,11 +208,11 @@ theorem gradedTensorOdd_naturality {A' B' : S.Mod.{u, u, u, u}} (TensorProduct.map uu.oddMap vv.evenMap)) := by refine LinearMap.prod_ext (TensorProduct.ext' fun x y => ?_) (TensorProduct.ext' fun x y => ?_) - · show (SuperCommAlgebra.Mod.tensorHom uu vv).oddMap + · change (SuperCommAlgebra.Mod.tensorHom uu vv).oddMap (tmulEO A B x y) = _ rw [tensorHom_oddMap_tmulEO] rfl - · show (SuperCommAlgebra.Mod.tensorHom uu vv).oddMap + · change (SuperCommAlgebra.Mod.tensorHom uu vv).oddMap (tmulOE A B x y) = _ rw [tensorHom_oddMap_tmulOE] rfl @@ -561,10 +561,10 @@ noncomputable def baseNuEven : (fun b t a => baseNuInnerEven_actEE P b t a) (fun _ _ _ => rfl) (fun c t v => by - show (0 : basePairEven P M N) = _ + change (0 : basePairEven P M N) = _ rw [pointMod_actOO, map_zero]) (fun c t a => by - show baseNuInnerEven P M N ((M.tensor N).actOO c t) a = -0 + change baseNuInnerEven P M N ((M.tensor N).actOO c t) a = -0 rw [baseNuInnerEven_actOO, neg_zero]) /-- **The inverse comparison in odd degree.** -/ @@ -575,10 +575,10 @@ noncomputable def baseNuOdd : (fun _ _ _ => rfl) (fun b t a => baseNuInnerOdd_actEO P b t a) (fun c t a => by - show baseNuInnerOdd P M N ((M.tensor N).actOE c t) a = 0 + change baseNuInnerOdd P M N ((M.tensor N).actOE c t) a = 0 rw [baseNuInnerOdd_actOE]) (fun c t v => by - show (0 : basePairOdd P M N) = -_ + change (0 : basePairOdd P M N) = -_ rw [pointMod_actOO, map_zero, neg_zero]) variable {M N} diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Functor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Functor.lean index f46de953ae..2f5947fabc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Functor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Functor.lean @@ -231,7 +231,7 @@ noncomputable def superVectFunctorBraided (superVectFunctor P G hE hO).Braided where toMonoidal := superVectFunctorMonoidal P G braided X Y := by - show (superVectMu P (G.obj X) (G.obj Y) ≫ + 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] @@ -264,14 +264,14 @@ theorem nonempty_braided_deligneFibre (hsp : SplitsOn L 𝔸 (indOf : C ⥤ Ind C)) (pt : SuperPoint (gammaAlgebra (Ind C) L 𝔸)) : Nonempty (deligneFibre L 𝔸 hsp pt).Braided := by - letI : ((indOf : C ⥤ Ind C) ⋙ fibreOver L 𝔸).Braided := + let : ((indOf : C ⥤ Ind C) ⋙ fibreOver L 𝔸).Braided := { toMonoidal := indFibreMonoidal L 𝔸 hsp braided := Functor.LaxBraided.braided } - haveI hE : ∀ X, FiniteDimensional ℂ + have hE : ∀ X, FiniteDimensional ℂ ((((indOf : C ⥤ Ind C) ⋙ fibreOver L 𝔸).obj X).tensor (pointMod pt)).even := finiteDimensional_indFibre_even L 𝔸 hsp pt - haveI hO : ∀ X, FiniteDimensional ℂ + have hO : ∀ X, FiniteDimensional ℂ ((((indOf : C ⥤ Ind C) ⋙ fibreOver L 𝔸).obj X).tensor (pointMod pt)).odd := finiteDimensional_indFibre_odd L 𝔸 hsp pt diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean index 75b3f2a5d4..8a94816cb6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean @@ -95,16 +95,16 @@ noncomputable def pointMulLin : (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 - show (a.down + b.down) * c.down = _ + change (a.down + b.down) * c.down = _ exact add_mul _ _ _)) (fun r a b => ULift.ext _ _ (by - show (r * a.down) * b.down = r * (a.down * b.down) + change (r * a.down) * b.down = r * (a.down * b.down) exact mul_assoc _ _ _)) (fun a b c => ULift.ext _ _ (by - show a.down * (b.down + c.down) = _ + change a.down * (b.down + c.down) = _ exact mul_add _ _ _)) (fun r a b => ULift.ext _ _ (by - show a.down * (r * b.down) = r * (a.down * b.down) + change a.down * (r * b.down) = r * (a.down * b.down) ring)) /-- The multiplication of the residue module, evaluated. -/ @@ -124,26 +124,26 @@ noncomputable def pointMulData : feo := 0 foe := 0 hee b m n := ULift.ext _ _ (by - show P.chi b * m.down * n.down = m.down * (P.chi b * n.down) + 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] - show (0 : (pointMod P).even) = pointMulLin P m 0 + change (0 : (pointMod P).even) = pointMulLin P m 0 rw [map_zero] hooe c m n := by rw [pointMod_actOO] - show pointMulLin P 0 n = -(0 : (pointMod P).even) + 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 - show P.chi a * m.down * n.down = P.chi a * (m.down * n.down) + change P.chi a * m.down * n.down = P.chi a * (m.down * n.down) ring) aoo a m n := by - show (0 : (pointMod P).even) = (pointMod P).actEE a 0 + change (0 : (pointMod P).even) = (pointMod P).actEE a 0 rw [map_zero] aeo _ _ _ := Subsingleton.elim _ _ aoe _ _ _ := Subsingleton.elim _ _ @@ -179,12 +179,12 @@ noncomputable def pointUnitHom : (P.chi.toLinearMap : S.even →ₗ[ℂ] ℂ) oddMap := 0 map_actEE x m := ULift.ext _ _ (by - show P.chi (S.mulEE x m) = P.chi x * P.chi m + 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 - show P.chi (S.mulOO u m) = (0 : ULift.{u} ℂ).down + change P.chi (S.mulOO u m) = (0 : ULift.{u} ℂ).down rw [P.vanishing] rfl) @@ -408,7 +408,7 @@ private theorem point_triple_ee (ULift.up (b.down * c.down)) := by rw [tensorHom_evenMap_tmulEE, pointMulHom_evenMap_tmulEE] rfl - show (pointMulHom P).evenMap + change (pointMulHom P).evenMap ((SuperCommAlgebra.Mod.tensorHom (pointMulHom P) (𝟙 (pointMod P))).evenMap (tmulEE ((pointMod P).tensor (pointMod P)) (pointMod P) @@ -423,7 +423,7 @@ private theorem point_triple_ee erw [e1, e2, e3, pointMulHom_evenMap_tmulEE, pointMulHom_evenMap_tmulEE] refine ULift.ext _ _ ?_ - show a.down * b.down * c.down = a.down * (b.down * c.down) + change a.down * b.down * c.down = a.down * (b.down * c.down) exact mul_assoc _ _ _ /-- **The multiplication of the residue module is associative.** -/ @@ -536,7 +536,7 @@ theorem pointBaseMu_associativity (M N Q : S.Mod.{u, u, u, u}) : ← whiskerLeft_comp_assoc, pointMulHom_assoc, whiskerLeft_comp_assoc, whisker_exchange, ← tensorHom_def'_assoc] - show tensorμ M (pointMod P) N (pointMod P) ▷ (Q ⊗ pointMod P) ≫ + 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) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointTensor.lean index 954e60c606..d52f5b0a6d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointTensor.lean @@ -30,7 +30,7 @@ theorem mono_of_point_ne_zero [MonoidalPreadditive A] [MonoidalLinear ℂ A] [RigidCategory A] (hu : HasScalarUnit A) {X : A} {u : 𝟙_ A ⟶ X} (h : u ≠ 0) : Mono u := by - haveI := simple_unit_of_hasScalarUnit hu + have := simple_unit_of_hasScalarUnit hu exact mono_of_nonzero_from_simple h /-- **The tensor of two nonzero points is a monomorphism.** -/ @@ -40,12 +40,12 @@ theorem mono_tensorHom_point (hu : HasScalarUnit A) {X Y : A} {u : 𝟙_ A ⟶ X} {v : 𝟙_ A ⟶ Y} (hu0 : u ≠ 0) (hv0 : v ≠ 0) : Mono (u ⊗ₘ v) := by - haveI : Mono u := mono_of_point_ne_zero hu hu0 - haveI : Mono v := mono_of_point_ne_zero hu hv0 - haveI hR : (tensorRight (𝟙_ A)).PreservesMonomorphisms := + 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)) - haveI hL : (tensorLeft X).PreservesMonomorphisms := + have hL : (tensorLeft X).PreservesMonomorphisms := Functor.preservesMonomorphisms_of_adjunction (tensorLeftAdjunction X (Xᘁ)) have hmu : Mono (u ▷ 𝟙_ A) := hR.preserves (f := u) @@ -60,7 +60,7 @@ theorem tensorHom_point_ne_zero (hu : HasScalarUnit A) {X Y : A} {u : 𝟙_ A ⟶ X} {v : 𝟙_ A ⟶ Y} (hu0 : u ≠ 0) (hv0 : v ≠ 0) : (u ⊗ₘ v) ≠ 0 := by - haveI := mono_tensorHom_point hu hu0 hv0 + have := mono_tensorHom_point hu hu0 hv0 intro h0 have hid : 𝟙 (𝟙_ A ⊗ 𝟙_ A) = 0 := by refine (cancel_mono (u ⊗ₘ v)).mp ?_ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowChain.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowChain.lean index 3f64d1ddfb..94145c22a7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowChain.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowChain.lean @@ -48,7 +48,7 @@ theorem modPowMul_modTensor_cond rfl, show actLeft A (modPowMod A X n).X = modPowAct A X n from rfl] - show (((β_ (modPow A X (m + 1)) A).hom ≫ modPowAct A X m) ▷ + 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)) ≫ @@ -105,7 +105,7 @@ theorem powMulDesc_act conv_rhs => rw [← whiskerLeft_comp_assoc, modTensorπ_powMulDesc] have h := modPowMul_actLeft A X m n - show (α_ A (modPow A X (m + 1)) (modPow A X (n + 1))).inv ≫ + 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)) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowInduct.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowInduct.lean index fde23d2755..fb24f9ef98 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowInduct.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowInduct.lean @@ -46,7 +46,7 @@ theorem powDualityDatum_succ (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 ?_ ?_ - · show modPowPairing A M M' d (n + 1) = + · 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) @@ -65,7 +65,7 @@ theorem powDualityDatum_succ 𝟙 (modPowMod A M.X (n + 1)) from powFrontModInv_powFrontMod A M.X n] rw [modTensorMap_id, Category.id_comp] - · show powCopairA A M M' d (n + 1) = + · 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowMerge.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowMerge.lean index 63ddd958bb..77c706656e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowMerge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowMerge.lean @@ -256,7 +256,7 @@ theorem headMod_act [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] have h0 : headMod A X 0 = (show X ⊗ tensorPow D X 0 ⟶ X from (ρ_ X).hom) ≫ (modPowOne A X).inv := by - show ((ρ_ X).hom ≫ (λ_ X).inv) ≫ modPowπ A X 1 = _ + change ((ρ_ X).hom ≫ (λ_ X).inv) ≫ modPowπ A X 1 = _ erw [Category.assoc] rfl have hu : (actLeft A X ▷ tensorPow D X 0) ≫ @@ -405,7 +405,7 @@ theorem modPowπ_actRight (α_ (tensorPow D X a) X A).hom ≫ (tensorPow D X a ◁ actRight A X) := braiding_actAcross A X (tensorPow D X a) - show (modPowπ A X (a + 1) ▷ 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairSucc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairSucc.lean index 2453564e2e..07d1121169 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairSucc.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairSucc.lean @@ -126,11 +126,7 @@ private theorem tensorHom_π_pairFold end Fold -/-- **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 +private theorem modPowPairing_succ_tensor_leftCover [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] @@ -139,70 +135,36 @@ theorem modPowPairing_succ_tensor (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)) ≫ + (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 - (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)) ≫ + (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) = - ((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 ⊗ₘ + 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) ≫ - 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)) ≫ + (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 - erw [← Category.assoc, - MonoidalCategory.tensorHom_comp_tensorHom] - -- The successor pairing against the swapped projection. have hstep : modTensorπ A (modPowMod A M.X (n + 1)) (modPowMod A M'.X (n + 1)) ≫ modTensorSwap A (modPowMod A M.X (n + 1)) @@ -298,17 +260,36 @@ theorem modPowPairing_succ_tensor exact MonoidalCategory.tensorHom_comp_tensorHom_assoc _ _ _ _ _ -- The triangle core, covered by the projections. - 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. + 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) ≫ @@ -348,8 +329,50 @@ theorem modPowPairing_succ_tensor rw [MonoidalCategory.tensorHom_comp_tensorHom_assoc, hswn, hsw0, ← MonoidalCategory.tensorHom_comp_tensorHom_assoc] -- The core identity over the cover. - have hmeet := hL2.symm.trans (hcov.trans hR2) - -- Braid the merged pair across the successor braiding. + 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) @@ -438,6 +461,37 @@ theorem modPowPairing_succ_tensor 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 @@ -473,6 +527,102 @@ theorem modPowPairing_succ_tensor 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) ⊗ₘ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean index 30af3af306..52abbf96eb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean @@ -317,7 +317,7 @@ theorem concat_peel_head [Category.{v} D] [MonoidalCategory D] (X : D) (X ◁ (tensorPowConcat X p q).hom) | 0 => by rw [tensorPowConcat_zero, tensorPowConcat_zero] - show (ρ_ (tensorPow D X (p + 1))).hom ≫ + 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 ≫ @@ -326,7 +326,7 @@ theorem concat_peel_head [Category.{v} D] [MonoidalCategory D] (X : D) monoidal | q + 1 => by rw [tensorPowConcat_succ, tensorPowConcat_succ] - show ((α_ (tensorPow D X (p + 1)) (tensorPow D X q) X).inv ≫ + 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) ≫ @@ -336,7 +336,7 @@ theorem concat_peel_head [Category.{v} D] [MonoidalCategory D] (X : D) (X ◁ ((α_ (tensorPow D X p) (tensorPow D X q) X).inv ≫ ((tensorPowConcat X p q).hom ▷ X))) rw [← powCast_whiskerRight] - simp only [Category.assoc] + all_goals simp only [Category.assoc] show (α_ (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) ≫ @@ -370,7 +370,7 @@ private theorem leg_step_snd_eq [Category.{v} D] [MonoidalCategory D] (X ◁ (((tensorPow D X a ◁ w) ▷ tensorPow D X b) ≫ modPowGlue X a b)) := by rw [modPowGlue, modPowGlue] - show ((tensorPow D X (a + 1) ◁ w) ▷ tensorPow D X b) ≫ + 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) ≫ @@ -992,7 +992,7 @@ private theorem leg_head_snd_eq [Category.{v} D] [MonoidalCategory D] (A : D) ((congrArg (fun t => (λ_ (tensorPow D X b)).hom ≫ t) (powCast_comp X _ _)).trans (Category.comp_id _)) rw [h5] - show ((𝟙_ D ◁ w) ▷ tensorPow D X b) ≫ + 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) ≫ @@ -1136,7 +1136,7 @@ theorem rawPair_rel_fst_top (α_ (tensorPow D M'.X a) M'.X M'.X).inv := by rw [modPowLegN]; exact leg_top_eq A M' _ a rw [hM, hN] - show (((ρ_ (tensorPow D M'.X a ⊗ ((M'.X ⊗ A) ⊗ M'.X))).hom ≫ + 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)) ≫ @@ -1150,7 +1150,7 @@ theorem rawPair_rel_fst_top simp only [comp_whiskerRight] repeat' erw [Category.assoc] rw [cancel_epi] - show ((tensorPow D M'.X a ◁ winLegM A M'.X) ▷ + 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)) ≫ @@ -1184,7 +1184,7 @@ private theorem leg_step_eq ((((tensorPow D M'.X a ◁ w) ▷ tensorPow D M'.X b) ≫ modPowGlue M'.X a b) ▷ M'.X) := by rw [modPowGlue, modPowGlue, tensorPowConcat_succ] - show ((tensorPow D M'.X a ◁ w) ▷ + 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)) ≫ @@ -1224,7 +1224,7 @@ theorem rawPair_rel_fst rw [modPowLegN, modPowLegN] exact leg_step_eq A M' _ a b rw [hM, hN] - show (((α_ (tensorPow D M'.X a ⊗ ((M'.X ⊗ A) ⊗ M'.X)) + 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)) ≫ @@ -1238,7 +1238,7 @@ theorem rawPair_rel_fst repeat' erw [Category.assoc] rw [cancel_epi] rw [rawPair_succ_step] - show ((modPowLegM A M'.X a b ▷ M'.X) ▷ + 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) ≫ @@ -1294,7 +1294,7 @@ theorem rawPair_rel_snd pairStep A M M' d (pairStep A M M' d (rawPair A M M' d b)) := by intro w - show ((tensorPow D M'.X (b + 1) ⊗ M'.X) ◁ + 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) ◁ @@ -1441,7 +1441,7 @@ private theorem powTailAct_peel rw [show (powPeel X (n + 1)).hom = ((powPeel X n).hom ▷ X) ≫ (α_ X (tensorPow D X n) X).hom from rfl] - show actAcross A (tensorPow D X (n + 1)) X ≫ + 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) ≫ @@ -1474,7 +1474,7 @@ theorem rawPair_actTail (α_ A M.X (tensorPow D M.X 0)).inv ≫ (actLeft A M.X ▷ tensorPow D M.X 0) := by rw [powTailAct_eq] - show ((α_ A (tensorPow D M.X 0) M.X).inv ≫ + 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)) ≫ @@ -1489,7 +1489,7 @@ theorem rawPair_actTail hact] conv_lhs => simp only [MonoidalCategory.whiskerLeft_comp] conv_lhs => erw [Category.assoc, Category.assoc] - show ((tensorPow D M'.X 0 ⊗ M'.X) ◁ + 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) ≫ @@ -1522,7 +1522,7 @@ theorem rawPair_actTail powTailAct_peel A] conv_lhs => simp only [MonoidalCategory.whiskerLeft_comp] conv_lhs => erw [Category.assoc, Category.assoc] - show ((tensorPow D M'.X (n + 1) ⊗ M'.X) ◁ + 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) ≫ @@ -1563,7 +1563,7 @@ private theorem braid_powTailAct (α_ (tensorPow D X n) X A).hom ≫ (tensorPow D X n ◁ actRight A X) := by rw [powTailAct_eq] - show (β_ (tensorPow D X n ⊗ X) A).hom ≫ + 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 ≫ @@ -1774,9 +1774,9 @@ theorem pairPow_middle_cond modTensorLegN A (modPowMod A M'.X n) (modPowMod A M.X n) ≫ pairPow A M M' d (n + 1) := by rw [modTensorLegM, modTensorLegN] - letI := modPowModObj A M'.X n - letI := modPowModObj A M.X n - show (actRight A (modPow A M'.X (n + 1)) ▷ + 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) ◁ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPoint.lean index b5853cb3da..b70567aa1f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPoint.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPoint.lean @@ -118,7 +118,7 @@ theorem tensorPowPoint_mono [Category.{v} D] [MonoidalCategory D] {Y : D} (pt : 𝟙_ D ⟶ Y) [RigidCategory D] [Mono pt] (n : ℕ) : Mono (tensorPowPoint pt n) := by - haveI := tensorPowMap_mono pt n + have := tensorPowMap_mono pt n exact mono_comp _ _ variable {Y} in @@ -130,7 +130,7 @@ theorem tensorPowPoint_mono' [∀ Z : D, (tensorRight Z).PreservesMonomorphisms] [Mono pt] (n : ℕ) : Mono (tensorPowPoint pt n) := by - haveI := tensorPowMap_mono' pt n + have := tensorPowMap_mono' pt n exact mono_comp _ _ variable {Y} in @@ -257,7 +257,7 @@ theorem tensorPowPoint_symPowIdem tensorPowPoint pt n ≫ modPowπ A X n := by rw [symPowIdem, symmetriser, map_smul, map_sum] simp only [modPowAlg_single] - show tensorPowPoint pt n ≫ modPowπ A X n ≫ + change tensorPowPoint pt n ≫ modPowπ A X n ≫ (((n.factorial : ℂ))⁻¹ • ∑ σ : Equiv.Perm (Fin n), (modPowPerm (A := A) (X := X) n σ : @@ -310,7 +310,7 @@ theorem point_symPow_ne_zero have := congrArg (fun t => t ≫ inv (modPowπ (𝟙_ D) X n)) h3 simpa using this - haveI := tensorPowPoint_mono pt n + 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]))) @@ -337,7 +337,7 @@ theorem point_symPow_ne_zero' have := congrArg (fun t => t ≫ inv (modPowπ (𝟙_ D) X n)) h3 simpa using this - haveI := tensorPowPoint_mono' pt n + 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]))) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSucc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSucc.lean index 4f1353070d..93c8eda909 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSucc.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSucc.lean @@ -207,7 +207,7 @@ theorem powCopairA_succ_tensor (by omega : 0 + 1 + n + 1 = n + 2)) (powMulMod A M'.X n 0)) h2) ?_ erw [reassoc_of% hpt] - show _ = powUnitStage A M M' d n ≫ powDelta A M M' d n + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSuccMod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSuccMod.lean index d1db4a4147..ee0bb67129 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSuccMod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSuccMod.lean @@ -49,7 +49,7 @@ theorem powSplit_act [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] 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 - haveI : IsIso (powMulDesc A X a b) := + 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, @@ -84,7 +84,7 @@ theorem powMulMod_powMulModInv 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 - show powMulDesc A X a b ≫ powSplit A X a b = 𝟙 _ + 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 @@ -100,7 +100,7 @@ theorem powMulModInv_powMulMod powMulModInv A X a b ≫ powMulMod A X a b = 𝟙 (modPowMod A X (a + 1 + b)) := by apply Mod.hom_ext - show powSplit A X a b ≫ powMulDesc A X a b = 𝟙 _ + 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 -/ @@ -118,7 +118,7 @@ theorem modPowCastMod_comp_id modPowCastMod A X h ≫ modPowCastMod A X h' = 𝟙 (modPowMod A X a) := by apply Mod.hom_ext - show modPowCast A X h ≫ modPowCast A X h' = 𝟙 _ + 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) @@ -135,7 +135,7 @@ theorem modTensorSwapMod_modTensorSwapMod modTensorSwapMod A P Q ≫ modTensorSwapMod A Q P = 𝟙 (modTensorMod A P Q) := by apply Mod.hom_ext - show modTensorSwap A P Q ≫ modTensorSwap A Q P = 𝟙 _ + change modTensorSwap A P Q ≫ modTensorSwap A Q P = 𝟙 _ exact modTensorSwap_modTensorSwap A P Q /-! ## The front insertion -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowTriangle.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowTriangle.lean index cf0b0f608e..0360c30c54 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowTriangle.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowTriangle.lean @@ -65,7 +65,7 @@ theorem modPowOne_pairPow ((λ_ M'.X).inv ⊗ₘ (λ_ M.X).inv) ≫ t) (modPowπ_tensor_pairPow A M M' d 1)).trans ?_) rw [rawPair_succ, rawPair_zero, powPeel_zero] - show ((λ_ M'.X).inv ⊗ₘ (λ_ M.X).inv) ≫ + 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) ≫ @@ -251,15 +251,10 @@ theorem tensorHom_π_interchange_map (f.hom ⊗ₘ g.hom) ≫ modTensorπ A Q R := modTensorπ_map A f g conv_lhs => arg 2; 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 f g = _ refine congrArg (CategoryStruct.comp _) ?_ refine (congrArg (CategoryStruct.comp _) h6).trans ?_ erw [← Category.assoc] - show ((modTensorπ A N₁ P₁ ⊗ₘ modTensorπ A N₂ P₂) ≫ + change ((modTensorπ A N₁ P₁ ⊗ₘ modTensorπ A N₂ P₂) ≫ (f.hom ⊗ₘ g.hom)) ≫ modTensorπ A Q R = _ erw [MonoidalCategory.tensorHom_comp_tensorHom] @@ -311,7 +306,7 @@ private theorem powDeltaCore_layer1 (β_ (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 - show modTensorπ A (modPowMod A M.X n) (modPowMod A M.X 0) ≫ + 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) = _ @@ -320,7 +315,7 @@ private theorem powDeltaCore_layer1 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 - show modTensorπ A (modPowMod A M'.X n) + 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] @@ -585,7 +580,7 @@ private theorem powDeltaCore_raw 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] - show ((𝟙_ D ⊗ M'.X) ◁ (λ_ M.X ≪≫ (ρ_ M.X).symm).hom) ≫ + 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)) ≫ @@ -702,7 +697,7 @@ private theorem powDeltaCore_layer2 (β_ (tensorPow D M.X (n + 2)) (tensorPow D M'.X (n + 2))).hom ≫ rawPair A M M' d (n + 2) := by - show (modPowπ A M.X (n + 2) ⊗ₘ modPowπ A M'.X (n + 2)) ≫ + 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, @@ -854,7 +849,7 @@ theorem powUnitStage_pairing modPowPairing A M M' d n = η[A] | 0 => powSeed_pairing A M M' d hzig | (n + 1) => by - show (powUnitStage A M M' d n ≫ powDelta A M M' d n) ≫ _ = _ + 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 @@ -1009,7 +1004,7 @@ theorem modPowPairing_linear 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 - letI := modTensorModObj A (modPowMod A M'.X n) + 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 @@ -1021,7 +1016,7 @@ theorem modPowPairing_linear modTensorπ_modPowPairing] conv_rhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc, modTensorπ_modPowPairing] - show (α_ A (modPow A M'.X (n + 1)) + 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) = diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZig.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZig.lean index 36a3578ae0..8d7fe41271 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZig.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZig.lean @@ -53,7 +53,7 @@ theorem powCopairA_zero d.copair ≫ modTensorMap A (toModPowModZero A M) (toModPowModZero A M') := by rw [powCopairA] - show (ρ_ A).inv ≫ (A ◁ (copairUnit A M M' d ≫ + 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) = _ @@ -190,7 +190,7 @@ theorem carrierContract_map rw [reassoc_of% hs2] refine congrArg (CategoryStruct.comp _) ?_ rw [whisker_exchange_assoc, whisker_exchange_assoc] - haveI := f.isModHom + 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]] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PresentedQuotient.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PresentedQuotient.lean index bd7b1fac19..2f86248218 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PresentedQuotient.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PresentedQuotient.lean @@ -92,7 +92,7 @@ noncomputable def liftEmbeddedIso [SmallCategory C] liftEmbedded F W θ ⋙ indOf ≅ F := NatIso.ofComponents (fun i => (θ i).symm) (by intro i j α - show indOf.map (Ind.yoneda.fullyFaithful.preimage + 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] @@ -183,15 +183,15 @@ theorem exists_iso_colimit_imageDiag (hepi : ∀ {T : Ind C} (a b : Q ⟶ T), (∀ i, f i ≫ a = f i ≫ b) → a = b) : Nonempty (Q ≅ colimit (imageDiag f hf)) := by - haveI : ∀ i : I, Mono ((imageDiagHom f hf).app i) := fun i => + have : ∀ i : I, Mono ((imageDiagHom f hf).app i) := fun i => inferInstanceAs (Mono (image.ι (f i))) - haveI : Mono (imageDiagHom f hf) := NatTrans.mono_of_mono_app _ - haveI : Mono (imageColimitDesc f hf) := + 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) - haveI : Epi (imageColimitDesc f hf) := by + 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 = @@ -206,7 +206,7 @@ theorem exists_iso_colimit_imageDiag ((Category.assoc _ _ _).trans ((whisker_eq _ h2).trans (Category.assoc _ _ _).symm))).trans (eq_whisker (image.fac (f i)) b) - haveI : IsIso (imageColimitDesc f hf) := isIso_of_mono_of_epi _ + have : IsIso (imageColimitDesc f hf) := isIso_of_mono_of_epi _ exact ⟨(asIso (imageColimitDesc f hf)).symm⟩ end ImageDiagram @@ -234,7 +234,7 @@ theorem quotientStage_comp (e : Z ≅ colimit D) (p : Z ⟶ Q) (i j : I) (α : i ⟶ j) : D.map α ≫ quotientStage e p j = quotientStage e p i := by - show D.map α ≫ colimit.ι D j ≫ e.inv ≫ p = + change D.map α ≫ colimit.ι D j ≫ e.inv ≫ p = colimit.ι D i ≫ e.inv ≫ p rw [← Category.assoc, colimit.w] @@ -266,9 +266,9 @@ theorem CountablyPresented.of_epi [SmallCategory C] [Abelian C] [Epi p] (h : CountablyPresented Z) : CountablyPresented Q := by classical obtain ⟨I, hcat, hfil, hcnt, G, ⟨e⟩⟩ := h - letI := hcat - letI := hfil - letI := hcnt + 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) @@ -309,9 +309,9 @@ theorem rank_hom_unit_le_aleph0_of_presented {Z : Ind C} (h : CountablyPresented Z) : Module.rank ℂ (𝟙_ (Ind C) ⟶ Z) ≤ Cardinal.aleph0 := by obtain ⟨I, hcat, hfil, hcnt, G, ⟨e⟩⟩ := h - letI := hcat - letI := hfil - letI := hcnt + 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))) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21.lean index 05b95a34ad..4b961086a7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21.lean @@ -49,18 +49,18 @@ theorem exists_fibre_functor Nonempty (Limits.PreservesFiniteColimits ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸)) ∧ ((indOf : C ⥤ Ind C) ⋙ fibreFun L 𝔸).Faithful := by - letI := linearOfScalarUnit ψ - letI := monoidalLinearOfScalarUnitBraided ψ - letI := linearOfScalarUnit (indScalarUnit ψ) - letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + let := linearOfScalarUnit ψ + let := monoidalLinearOfScalarUnitBraided ψ + let := linearOfScalarUnit (indScalarUnit ψ) + let := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) obtain ⟨𝔸, hmon, hcomm, hne, hsp, hsec⟩ := exists_fibre_algebra ψ P P₀ L hkill - letI := hmon - letI := hcomm - haveI hmono : Mono η[𝔸] := + let := hmon + let := hcomm + have hmono : Mono η[𝔸] := mono_unit_ind (simple_unit_of_hasScalarUnit (hasScalarUnit_of_scalarUnit ψ)) 𝔸 hne - haveI hpm : ∀ Z : Ind C, (tensorRight Z).PreservesMonomorphisms := + have hpm : ∀ Z : Ind C, (tensorRight Z).PreservesMonomorphisms := fun Z => inferInstance exact ⟨𝔸, hmon, hcomm, hne, ⟨indFibreMonoidal L 𝔸 hsp⟩, ⟨indFibre_preservesFiniteLimits L 𝔸 hsec⟩, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21Core.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21Core.lean index d0b305dc80..7ff8132a89 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21Core.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21Core.lean @@ -50,10 +50,10 @@ theorem exists_fibre_algebra 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 - letI := linearOfScalarUnit ψ - letI := monoidalLinearOfScalarUnitBraided ψ - letI := linearOfScalarUnit (indScalarUnit ψ) - letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21General.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21General.lean index 4c2473bf82..98c6db119e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21General.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21General.lean @@ -94,10 +94,10 @@ theorem exists_fibre_functor_general fibreFun doubledIndOddLine 𝔸)) ∧ (Doubled.evenEmbed ⋙ (indOf : Doubled A ⥤ Ind (Doubled A)) ⋙ fibreFun doubledIndOddLine 𝔸).Faithful := by - letI := linearOfScalarUnit (doubledScalarUnit hu) - letI := monoidalLinearOfScalarUnitBraided (doubledScalarUnit hu) - letI := linearOfScalarUnit (indScalarUnit (doubledScalarUnit hu)) - letI := monoidalLinearOfScalarUnitBraided + 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₀ @@ -105,12 +105,12 @@ theorem exists_fibre_functor_general (forall_exists_schurKilled P (hasScalarUnit_of_scalarUnit (doubledScalarUnit hu)) (moderateLengthGrowth_doubled hgrow)) - letI := hmon - letI := hcomm - letI := hM - letI := hL - letI := hCo - letI := hF + let := hmon + let := hcomm + let := hM + let := hL + let := hCo + let := hF exact ⟨𝔸, hmon, hcomm, hne, ⟨inferInstance⟩, ⟨comp_preservesFiniteLimits _ _⟩, ⟨comp_preservesFiniteColimits _ _⟩, inferInstance⟩ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29State.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29State.lean index ff893ab488..27faea04de 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29State.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29State.lean @@ -127,8 +127,8 @@ theorem devissageExit (L : OddLine D) (X : D) : DevissageExit D L X := by intro st hz - letI := st.monObj - letI := st.comm + 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 ?_⟩⟩ @@ -139,12 +139,12 @@ theorem devissageExit refine ⟨modBiprodFst st.base _ st.rest, modBiprodInl st.base _ st.rest, ?_, ?_⟩ · apply Mod.Hom.ext - show (biprod.fst ≫ biprod.inl : + 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 - show (biprod.inl ≫ biprod.fst : _ ⟶ _) = 𝟙 _ + change (biprod.inl ≫ biprod.fst : _ ⟶ _) = 𝟙 _ rw [biprod.inl_fst] /-- **The trichotomy**: over any state, either every symmetric diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Chain.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Chain.lean index 332c8efff3..62b008e297 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Chain.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Chain.lean @@ -203,7 +203,7 @@ theorem splitSeed_mu_right (i : ℕ) : (splitStage Y i ◁ splitSeed Y pt) ≫ splitMu Y i 0 = (ρ_ (splitStage Y i)).hom ≫ splitDelta Y pt i := by - show (splitStage Y i ◁ splitSeed Y pt) ≫ + 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) = @@ -269,7 +269,7 @@ theorem splitMu_comm [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] chainCast (splitStage Y) (by omega : j + 1 + i = i + 1 + j) = splitMu Y i j := by - show (β_ (symPow (𝟙_ D) Y (i + 1)) + change (β_ (symPow (𝟙_ D) Y (i + 1)) (symPow (𝟙_ D) Y (j + 1))).hom ≫ (symMul (𝟙_ D) Y (j + 1) (i + 1) ≫ symPowCast (𝟙_ D) Y @@ -295,7 +295,7 @@ private theorem chainCast_splitDelta chainCast (splitStage Y) (congrArg Nat.succ h) := by subst h rw [chainCast_rfl, Category.id_comp] - show splitDelta Y pt a = splitDelta Y pt a ≫ 𝟙 _ + change splitDelta Y pt a = splitDelta Y pt a ≫ 𝟙 _ rw [Category.comp_id] /-- **Left transition law**: transitioning the first factor and diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Close.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Close.lean index a0a80b4be5..ced46e174f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Close.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Close.lean @@ -55,10 +55,10 @@ theorem rappel210_of_unit_nonzero (hnz : splitAlgebraUnit ((unitFormMid S)ᘁ) (unitFormPoint S) ≠ 0) : Rappel210Statement S hS := by - letI : MonObj (rappel210Algebra S) := + let : MonObj (rappel210Algebra S) := splitAlgebraMonObj (((unitFormMid S)ᘁ : D)) (unitFormPoint S) - haveI : IsCommMonObj (rappel210Algebra S) := + have : IsCommMonObj (rappel210Algebra S) := splitAlgebra_isCommMonObj (((unitFormMid S)ᘁ : D)) (unitFormPoint S) exact rappel210_of_class S hS (rappel210Algebra S) hnz diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Ind.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Ind.lean index c280584cbf..e323f597f4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Ind.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Ind.lean @@ -42,7 +42,7 @@ theorem splitAlgebraUnit_ne_zero_ind (h1 : ¬ IsZero (𝟙_ (Ind C))) : splitAlgebraUnit (((unitFormMid S)ᘁ) : Ind C) (unitFormPoint S) ≠ 0 := by - haveI hmono : Mono (unitFormPoint S) := + have hmono : Mono (unitFormPoint S) := mono_unitFormPoint S hS intro h0 obtain ⟨n, hn⟩ := (chainColimitUnit_eq_zero_iff diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Reduce.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Reduce.lean index 3b4e235d83..8703514929 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Reduce.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Reduce.lean @@ -53,11 +53,11 @@ theorem ShortExact_tensorLeft [Category.{v} D] [MonoidalCategory D] [Abelian D] (hS : S.ShortExact) (X : D) [HasLeftDual X] [HasRightDual X] : (S.map (tensorLeft X)).ShortExact := by - haveI := tensorLeftPreservesColimits X - haveI := tensorLeftPreservesLimits X - haveI : PreservesFiniteColimits (tensorLeft X) := + have := tensorLeftPreservesColimits X + have := tensorLeftPreservesLimits X + have : PreservesFiniteColimits (tensorLeft X) := PreservesColimitsOfSize.preservesFiniteColimits _ - haveI : PreservesFiniteLimits (tensorLeft X) := + have : PreservesFiniteLimits (tensorLeft X) := PreservesLimitsOfSize.preservesFiniteLimits _ exact hS.map_of_exact (tensorLeft X) @@ -118,21 +118,21 @@ theorem unitForm_shortExact (hS : S.ShortExact) : (unitForm S).ShortExact := by have hT := ShortExact_tensorLeft hS ((S.X₃)ᘁ) - haveI hmf : Mono (((S.X₃)ᘁ) ◁ S.f) := hT.mono_f - haveI : Mono ((S.map (tensorLeft ((S.X₃)ᘁ))).f) := hT.mono_f - haveI hepig : Epi (((S.X₃)ᘁ) ◁ S.g) := hT.epi_g + 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 - haveI h1 : Mono (unitFormIn S ≫ + 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₃)) - haveI : Mono ((unitForm S).f) := hmono + 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 => ?_) @@ -171,10 +171,10 @@ theorem mono_rightAdjointMate [Category.{v} D] [MonoidalCategory D] [∀ W : D, (tensorLeft W).PreservesEpimorphisms] (f : X ⟶ Y) (hf : Epi f) : Mono (fᘁ) := by - haveI := hf + have := hf constructor intro W a b h - haveI : Epi (W ◁ f) := (tensorLeft W).map_epi f + 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 @@ -397,7 +397,7 @@ noncomputable def freeModExtend [Category.{v} D] [MonoidalCategory D] (M : Mod D B) (q : V ⟶ M.X) : freeMod B V ⟶ M := Mod.Hom.mk' ((B ◁ q) ≫ actLeft B M.X) (by - show ((α_ B B V).inv ≫ (μ[B] ▷ V)) ≫ + 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) = @@ -450,7 +450,7 @@ theorem freeSection_hom (B : D) [MonObj B] (cls : ((unitFormMid S)ᘁ) ⟶ B) : (freeSection S B cls).hom = freeSectionHom S B cls := by - show (B ◁ (pointSection S B cls ≫ + change (B ◁ (pointSection S B cls ≫ (β_ (unitFormMid S) B).hom)) ≫ ((α_ B B (unitFormMid S)).inv ≫ (μ[B] ▷ unitFormMid S)) = @@ -714,7 +714,7 @@ theorem rappel210Section_splits rappel210Section S B cls ≫ freeModMap B S.g = 𝟙 (freeMod B (S.X₃)) := Mod.hom_ext _ _ (by - show ((B ◁ sectionPoint S B cls) ≫ + change ((B ◁ sectionPoint S B cls) ≫ ((α_ B B (S.X₂)).inv ≫ (μ[B] ▷ S.X₂))) ≫ (B ◁ S.g) = 𝟙 (B ⊗ S.X₃) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean index bf37bbf98a..a08881205b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean @@ -71,7 +71,7 @@ theorem mv_eval_zero_fin : (Set.infinite_univ.image ((C_injective (Fin m) ℂ).injOn (s := Set.univ))) rintro _ ⟨r, -, rfl⟩ - show Polynomial.IsRoot _ (C r) + change Polynomial.IsRoot _ (C r) rw [Polynomial.IsRoot] apply ih intro s @@ -278,12 +278,12 @@ theorem diagramSchur_injective {lam mu : YoungDiagram} -- 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), if_pos rfl] + (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 [if_neg hne] at h1 + 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 → @@ -481,18 +481,18 @@ theorem SchurPackage.e_ne_zero (P : SchurPackage.{u}) /-- Coefficients of an element commuting with the whole group algebra are conjugation-invariant. -/ -theorem coeff_conj_of_comm {G : Type*} [Group G] [Fintype G] - [DecidableEq G] (x : MonoidAlgebra ℂ G) +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.mul_single_apply x 1 c (c * g)] at h + 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.single_mul_apply x 1 c (c * g)] at h + 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 @@ -581,7 +581,7 @@ theorem cycExp_eq_iff {n : ℕ} (π π' : Equiv.Perm (Fin n)) : · have happ := congrArg (fun f : ℕ →₀ ℕ => f c) h simp only [cycExp, Finsupp.add_apply, Multiset.toFinsupp_apply, Finsupp.single_apply] at happ - simp only [if_neg (fun h1 : (1 : ℕ) = c => hc h1.symm), + simp only [ite_eq_right (fun h1 : (1 : ℕ) = c => hc h1.symm), add_zero] at happ exact happ exact Multiset.ext.mpr hcount @@ -619,12 +619,12 @@ theorem classFun_eq_zero_of_cycleProd {n : ℕ} (if cycExp π = cycExp π₀ then δ π else 0) = (if cycExp π = cycExp π₀ then δ π₀ else 0) from by by_cases hπ : cycExp π = cycExp π₀ - · rw [if_pos hπ, if_pos hπ] + · 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 [if_neg hπ, if_neg hπ])] at hcoeff + · 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 π₀) := @@ -719,7 +719,7 @@ theorem isIrreducible_comp_permCastHom {m n : ℕ} (h : m = n) have hid : permCastHom (rfl : m = m) = MonoidHom.id (Equiv.Perm (Fin m)) := by refine MonoidHom.ext fun g => ?_ - show permCast rfl g = g + change permCast rfl g = g rw [permCast_rfl] rfl rw [hid, MonoidHom.comp_id] @@ -747,7 +747,7 @@ theorem e_mul_e_eq_zero_of_ne (P : SchurPackage.{u}) {n : ℕ} c' (c * g * c⁻¹) = c' g := by intro g c rw [hc'def] - show nCoeff (jtSimple mu) + change nCoeff (jtSimple mu) ((permCast hm).symm (c * g * c⁻¹)) = _ rw [permCast_symm, permCast_mul, permCast_mul, permCast_inv] exact nCoeff_classFun (jtSimple mu) _ _ @@ -763,8 +763,8 @@ theorem e_mul_e_eq_zero_of_ne (P : SchurPackage.{u}) {n : ℕ} by_cases hiso : Nonempty ((rhoS (jtSimple lam)).Equiv (rhoS T)) swap - · rw [if_neg hiso, zero_smul, smul_zero] - rw [if_pos hiso, one_smul] + · 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 @@ -779,15 +779,15 @@ theorem e_mul_e_eq_zero_of_ne (P : SchurPackage.{u}) {n : ℕ} -- the pulled-back representation of the common simple set ρ' : Representation ℂ (Equiv.Perm (Fin mu.card)) (subCarrier T) := (rhoS T).comp (permCastHom hm) with hρ' - haveI hirr' : ρ'.IsIrreducible := + have hirr' : ρ'.IsIrreducible := isIrreducible_comp_permCastHom hm (rhoS T) (rhoS_isIrreducible T hT) - haveI hirrS : (rhoS (jtSimple mu)).IsIrreducible := + 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 - haveI : Invertible ((Nat.card (Equiv.Perm (Fin mu.card)) : ℂ)) := + have : Invertible ((Nat.card (Equiv.Perm (Fin mu.card)) : ℂ)) := invertibleOfNonzero hcard0 have horth := Representation.char_orthonormal ρ' (rhoS (jtSimple mu)) @@ -814,7 +814,7 @@ theorem e_mul_e_eq_zero_of_ne (P : SchurPackage.{u}) {n : ℕ} -- a common simple forces the characters to agree have hiso2 : Nonempty ((rhoS (jtSimple mu)).Equiv ρ') := by by_contra hempty - rw [hre, hval, hval2, if_neg hempty, mul_zero, mul_zero] + rw [hre, hval, hval2, ite_eq_right hempty, mul_zero, mul_zero] at hne0 exact hne0 rfl obtain ⟨φlam⟩ := hiso @@ -974,8 +974,8 @@ theorem one_eq_classElem_ite (n : ℕ) : Finsupp.single_apply] by_cases hk : k = 1 · subst hk - rw [if_pos rfl] - · rw [if_neg (fun h => hk h.symm), if_neg 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 : ℕ} @@ -1043,8 +1043,8 @@ theorem one_mem_span_classSum (n : ℕ) : (if g = 1 then (1 : ℂ) else 0) by_cases hg : g = 1 · subst hg - rw [if_pos rfl, if_pos (by group)] - · rw [if_neg hg, if_neg (fun h => hg (by + 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))] @@ -1056,7 +1056,7 @@ theorem eq_sum_shape_e_of_mem_span (P : SchurPackage.{u}) {n : ℕ} ∃ c : Shape n → ℂ, ∑ μ, c μ • Shape.e P μ = x := by classical set W := Submodule.span ℂ (Set.range (classSum n)) with hWdef - haveI : FiniteDimensional ℂ W := + 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))) ?_ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoBiprod.lean index 4006f582a0..3b79c3310e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoBiprod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoBiprod.lean @@ -43,7 +43,7 @@ noncomputable def homBiproductEquiv rw [biproduct.lift_π] right_inv h := by funext j - show biproduct.lift h ≫ biproduct.π f j = h j + change biproduct.lift h ≫ biproduct.π f j = h j rw [biproduct.lift_π] end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RowColIdem.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RowColIdem.lean index 7dd4611ede..030a5db372 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RowColIdem.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RowColIdem.lean @@ -45,7 +45,7 @@ theorem newtonH_zero_fun (m : ℕ) : newtonH (fun _ => (0 : ℂ)) (m + 1) = 0 := by rw [newtonH] rw [Finset.sum_congr rfl fun i _ => by - show (fun _ => (0 : ℂ)) (i + 1) * _ = (0 : ℂ) + change (fun _ => (0 : ℂ)) (i + 1) * _ = (0 : ℂ) exact zero_mul _] rw [Finset.sum_const_zero, mul_zero] @@ -73,7 +73,7 @@ theorem newtonH_alt (t : ℕ → ℂ) : rw [← pow_add, ← pow_succ] congr 1 omega - show (-1 : ℂ) ^ (i + 1 + 1) * t (i + 1) * + 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)) @@ -212,13 +212,13 @@ noncomputable def negHMat (t : ℕ → ℂ) (n : ℕ) : theorem negHMat_det (t : ℕ → ℂ) (n : ℕ) : (negHMat t n).det = 1 := by have htri : (negHMat t n).BlockTriangular id := by intro i j hij - show newtonHZ (fun c => -t c) ((j : ℤ) - (i : ℤ)) = 0 + change newtonHZ (fun c => -t c) ((j : ℤ) - (i : ℤ)) = 0 refine newtonHZ_neg _ _ ?_ have : (j : ℕ) < (i : ℕ) := hij omega - rw [Matrix.det_of_upperTriangular htri] + rw [Matrix.det_of_isUpperTriangular htri] refine Finset.prod_eq_one fun i _ => ?_ - show newtonHZ (fun c => -t c) ((i : ℤ) - (i : ℤ)) = 1 + change newtonHZ (fun c => -t c) ((i : ℤ) - (i : ℤ)) = 1 rw [sub_self, show (0 : ℤ) = ((0 : ℕ) : ℤ) from rfl, newtonHZ_natCast, newtonH_zero] @@ -233,7 +233,7 @@ private theorem conv_sum_pos (t : ℕ → ℂ) {n ik kk : ℕ} 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 [if_neg (by omega)] + 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), @@ -315,10 +315,10 @@ private theorem conv_sum_pos (t : ℕ → ℂ) {n ik kk : ℕ} 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, if_pos (by omega)] + · 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, if_neg (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. -/ @@ -333,7 +333,7 @@ private theorem conv_sum_zero (t : ℕ → ℂ) {n kk : ℕ} (fun d => newtonH t d * newtonH (fun c => -t c) (kk + 1 - d)) (j + 1) := by intro j _ - show _ = newtonH t (j + 1) * + 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), @@ -352,7 +352,7 @@ private theorem conv_sum_zero (t : ℕ → ℂ) {n kk : ℕ} have h0 : (fun d => newtonH t d * newtonH (fun c => -t c) (kk + 1 - d)) 0 = newtonH (fun c => -t c) (kk + 1) := by - show newtonH t 0 * newtonH (fun c => -t c) (kk + 1 - 0) = _ + 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 : ℤ)) * @@ -450,14 +450,14 @@ theorem colJTMat_det (t : ℕ → ℂ) (n : ℕ) : rw [colJT_mul_negH_pos t _ _ (by rw [coe_finRotate_of_ne_last hne] omega)] - rw [if_neg (by + 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_lowerTriangular _ htri] + 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 @@ -469,7 +469,7 @@ theorem colJTMat_det (t : ℕ → ℂ) (n : ℕ) : rw [colJT_mul_negH_pos t _ _ (by rw [coe_finRotate_of_ne_last hne] omega)] - rw [if_pos (by rw [coe_finRotate_of_ne_last hne])] + 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] @@ -525,7 +525,7 @@ theorem sign_mul_cycleProd (t : ℕ → ℂ) {n : ℕ} (π : Equiv.Perm (Fin n)) : ((Equiv.Perm.sign π : ℤ) : ℂ) * cycleProd t π = cycleProd (fun c => (-1) ^ (c + 1) * t c) π := by - show ((Equiv.Perm.sign π : ℤ) : ℂ) * + 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichZig.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichZig.lean index 030c093790..558c818732 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichZig.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichZig.lean @@ -43,7 +43,7 @@ theorem sandwichIns_sandwichCon have hcar := zig_carrier_of_multi A d.copair d.pair d.pair_linear hz.zig refine Eq.trans ?_ hcar - show (sandwichIns A d).hom ≫ (sandwichCon A d).hom = _ + 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 _ ?_ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarBraiding.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarBraiding.lean index be1023bb94..0697afb9e7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarBraiding.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarBraiding.lean @@ -97,18 +97,18 @@ theorem permMor_of_scalar (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, if_pos rfl, + | 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 [if_pos hs, hs] + · rw [ite_eq_left hs, hs] norm_num · have hs' : Equiv.Perm.sign σ = -1 := (Int.units_eq_one_or _).resolve_left hs - rw [if_neg hs, hs'] + rw [ite_eq_right hs, hs'] norm_num [hc2] /-- The group-algebra action under a scalar self-braiding is @@ -258,7 +258,7 @@ theorem schurKilled_of_braiding_id ∑ σ : 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, - if_neg (by omega), mul_zero, zero_smul] + 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 @@ -281,13 +281,13 @@ theorem schurKilled_of_braiding_neg ((Equiv.Perm.sign σ : ℤ) : ℂ) from Finset.sum_congr rfl fun σ _ => by by_cases hs : Equiv.Perm.sign σ = 1 - · rw [if_pos hs, hs] + · rw [ite_eq_left hs, hs] norm_num - · rw [if_neg hs, + · rw [ite_eq_right hs, (Int.units_eq_one_or _).resolve_left hs] norm_num] rw [sum_e_coeff_sign, diagramSchur_superPS_col, - if_neg (by omega), mul_zero, zero_smul] + ite_eq_right (by omega), mul_zero, zero_smul] /-- The unit is killed at the two-cell column. -/ theorem schurKilled_unit_col diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarLinear.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarLinear.lean index 38924ae7a0..26009fb5d2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarLinear.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarLinear.lean @@ -222,25 +222,25 @@ unit. -/ Module ℂ (X ⟶ Y) where smul c f := scalarSmul φ c f one_smul f := by - show scalarSmul φ 1 f = f + change scalarSmul φ 1 f = f rw [scalarSmul_eq, scalarEnd_one, Category.id_comp] mul_smul a b f := by - show scalarSmul φ (a * b) f = scalarSmul φ a (scalarSmul φ b f) + 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 - show scalarSmul φ c 0 = 0 + change scalarSmul φ c 0 = 0 rw [scalarSmul_eq, Limits.comp_zero] smul_add c f g := by - show scalarSmul φ c (f + g) = scalarSmul φ c f + scalarSmul φ c g + 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 - show scalarSmul φ (a + b) f = scalarSmul φ a f + scalarSmul φ b f + 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 - show scalarSmul φ 0 f = 0 + change scalarSmul φ 0 f = 0 rw [scalarSmul_eq, scalarEnd_zero, Limits.zero_comp] /-- **ℂ-linearity from the scalar unit**: a ring isomorphism @@ -254,10 +254,10 @@ every existing linear structure, so callers install it by `letI`. -/ CategoryTheory.Linear ℂ D where homModule X Y := scalarModule φ X Y smul_comp X Y Z r f g := by - show scalarSmul φ r f ≫ g = scalarSmul φ r (f ≫ g) + 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 - show f ≫ scalarSmul φ r g = scalarSmul φ r (f ≫ g) + change f ≫ scalarSmul φ r g = scalarSmul φ r (f ≫ g) rw [scalarSmul_eq, scalarSmul_eq, ← Category.assoc, ← scalarEnd_naturality, Category.assoc] @@ -272,12 +272,12 @@ theorem monoidalLinearOfScalarUnit (h : ScalarBalanced φ) : letI := linearOfScalarUnit φ MonoidalLinear ℂ D := by - letI := linearOfScalarUnit φ + let := linearOfScalarUnit φ refine ⟨fun X {Y Z} r f => ?_, fun r {Y Z} f X => ?_⟩ - · show X ◁ scalarSmul φ r f = scalarSmul φ r (X ◁ f) + · change X ◁ scalarSmul φ r f = scalarSmul φ r (X ◁ f) rw [scalarSmul_eq, scalarSmul_eq, MonoidalCategory.whiskerLeft_comp, whiskerLeft_scalarEnd φ h] - · show scalarSmul φ r f ▷ X = scalarSmul φ r (f ▷ X) + · change scalarSmul φ r f ▷ X = scalarSmul φ r (f ▷ X) rw [scalarSmul_eq, scalarSmul_eq, comp_whiskerRight, scalarEnd_whiskerRight] @@ -325,16 +325,16 @@ colimits, hence binary biproducts, between preadditive categories. -/ theorem indOf_additive [SmallCategory C] [Preadditive C] [HasFiniteColimits C] : (indOf (C := C)).Additive := by - haveI : Limits.HasFiniteBiproducts C := + have : Limits.HasFiniteBiproducts C := Limits.HasFiniteBiproducts.of_hasFiniteCoproducts - haveI : Limits.HasBinaryBiproducts C := + have : Limits.HasBinaryBiproducts C := Limits.hasBinaryBiproducts_of_finite_biproducts C - haveI : Limits.HasBinaryBiproducts (Ind C) := + have : Limits.HasBinaryBiproducts (Ind C) := Limits.hasBinaryBiproducts_of_finite_biproducts (Ind C) - haveI : (indOf (C := C)).PreservesZeroMorphisms := + have : (indOf (C := C)).PreservesZeroMorphisms := Functor.preservesZeroMorphisms_of_map_zero_object (isZero_indOf (Limits.isZero_zero C)).isoZero - haveI := Limits.preservesBinaryBiproducts_of_preservesBinaryCoproducts + have := Limits.preservesBinaryBiproducts_of_preservesBinaryCoproducts (indOf (C := C)) exact Functor.additive_of_preservesBinaryBiproducts _ @@ -350,7 +350,7 @@ def indOfEndRingEquiv [SmallCategory C] [Preadditive C] [HasFiniteColimits C] map_mul' f g := by rw [End.mul_def, End.mul_def, Functor.map_comp] map_add' f g := by - haveI := indOf_additive (C := C) + have := indOf_additive (C := C) exact Functor.map_add (F := indOf (C := C)) /-- **The scalar unit of `Ind C`**: a ring isomorphism diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitEquiv.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitEquiv.lean index ffc13c97cf..71fc921a43 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitEquiv.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitEquiv.lean @@ -31,7 +31,7 @@ def scalarUnitRingHom toFun c := c • 𝟙 (𝟙_ A) map_one' := one_smul _ _ map_mul' a b := by - show (a * b) • 𝟙 (𝟙_ A) = (b • 𝟙 (𝟙_ A)) ≫ (a • 𝟙 (𝟙_ A)) + 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 _ _ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitInd.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitInd.lean index 3917f4e3ba..ecfba13f1d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitInd.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitInd.lean @@ -40,11 +40,11 @@ theorem hasScalarUnit_of_scalarUnit (φ : ℂ ≃+* End (𝟙_ D)) : letI := linearOfScalarUnit φ HasScalarUnit D := by - letI := linearOfScalarUnit φ + let := linearOfScalarUnit φ have hval : ∀ c : ℂ, (c • 𝟙 (𝟙_ D) : 𝟙_ D ⟶ 𝟙_ D) = scalarHom φ c := by intro c - show scalarSmul φ c (𝟙 (𝟙_ D)) = scalarHom φ c + change scalarSmul φ c (𝟙 (𝟙_ D)) = scalarHom φ c rw [scalarSmul_eq, Category.comp_id, scalarEnd_unit] constructor · intro a b hab @@ -53,9 +53,9 @@ theorem hasScalarUnit_of_scalarUnit exact h1 · intro f refine ⟨φ.symm f, ?_⟩ - show ((φ.symm f) • 𝟙 (𝟙_ D) : 𝟙_ D ⟶ 𝟙_ D) = f + change ((φ.symm f) • 𝟙 (𝟙_ D) : 𝟙_ D ⟶ 𝟙_ D) = f rw [hval] - show (φ (φ.symm f) : 𝟙_ D ⟶ 𝟙_ D) = f + 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 index 5620e41b67..8898450b54 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean @@ -184,7 +184,7 @@ lemma dayCoyonedaIso_hom_leftUnitor [SmallCategory D] [MonoidalCategory D] (dayCoyonedaUnitElt (𝟙_ D) a)) rw [dayCoyonedaIso_hom_app_unitElt, whiskerRight_dayUnitIso_inv_app_unitElt, day_leftUnitor_hom_app_eta] - show 𝟙 a ≫ (λ_ a).inv = (λ_ a).inv ≫ 𝟙 (𝟙_ D ⊗ a) + 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, @@ -417,8 +417,8 @@ theorem permAlg_indOf_conj {C : Type v} [SmallCategory C] [MonoidalCategory C] letI := linearOfScalarUnit (indScalarUnit ψ) permAlg (indOf.obj X) n x ≫ (indOfPowIso X n).hom = (indOfPowIso X n).hom ≫ indOf.map (permAlg X n x) := by - letI := linearOfScalarUnit (indScalarUnit ψ) - haveI := indOf_additive (C := C) + let := linearOfScalarUnit (indScalarUnit ψ) + have := indOf_additive (C := C) induction x using MonoidAlgebra.induction_on with | of σ => rw [MonoidAlgebra.of_apply, permAlg_single, permAlg_single] @@ -447,7 +447,7 @@ theorem schurKilled_indOf_iff {X : C} {μ : YoungDiagram} : letI := linearOfScalarUnit (indScalarUnit ψ) (SchurKilled P (indOf.obj X) μ ↔ SchurKilled P X μ) := by - letI := linearOfScalarUnit (indScalarUnit ψ) + let := linearOfScalarUnit (indScalarUnit ψ) have hconj : permAlg (indOf.obj X) μ.card (P.e μ) = (indOfPowIso X μ.card).hom ≫ indOf.map (permAlg X μ.card (P.e μ)) ≫ @@ -465,7 +465,7 @@ theorem schurKilled_indOf_iff (indOfPowIso X μ.card).hom simpa using h1 · intro h0 - show permAlg (indOf.obj X) μ.card (P.e μ) = 0 + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean index d86bbce6fa..e1ec77d21b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean @@ -1213,28 +1213,24 @@ private theorem symInsL_zero show symPowCast A X (by omega : 1 + (0 + 1) = 0 + 2) = 𝟙 (symPow A X (0 + 2)) from rfl, Category.comp_id] -/-- **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] +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) : - ((((symPowOne A M'.X).inv ⊗ₘ (symPowOne A M.X).inv) ≫ + ((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) ≫ + (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. + 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)) ≫ @@ -1294,6 +1290,65 @@ theorem pairIns [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] -- 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)) ≫ @@ -1353,41 +1408,7 @@ theorem pairIns [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] (MonoidalCategory.tensorHom_def _ _).symm -- Assemble both sides at the common form -- tensorμ ≫ (symInsL ⊗ symInsL) ≫ π. - 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 _ + 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) ≫ @@ -2096,9 +2117,7 @@ private theorem pairPrefix_coh' rw [hsplit, hsplit'] rw [reassoc_of% (pairPrefix_coh A M M')] -/-- **The two seed routes agree**: feeding the seeds through the -pair equals feeding them through the transition. -/ -private theorem pairSeed_match +private theorem pairSeed_tensor_prefix [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] @@ -2116,10 +2135,18 @@ private theorem pairSeed_match (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 + (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 @@ -2140,6 +2167,38 @@ private theorem pairSeed_match ((ρ_ 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))) ≫ @@ -2208,14 +2267,7 @@ private theorem pairSeed_match (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 - 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] + (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 ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SignConj.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SignConj.lean index d19e84abc0..462c32d3f4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SignConj.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SignConj.lean @@ -158,7 +158,7 @@ theorem twistPow_symIdem_conj modPowPerm (A := A) (X := R.X) (k + 1) σ) := by rw [altPowIdem, antisymmetriser, map_smul, map_sum] simp only [halt] - show tensorPow D L.obj (k + 1) ◁ + change tensorPow D L.obj (k + 1) ◁ (((Nat.factorial (k + 1) : ℂ))⁻¹ • ∑ σ : Equiv.Perm (Fin (k + 1)), ((Equiv.Perm.sign σ : ℤ) : ℂ) • @@ -189,7 +189,7 @@ theorem twistPow_symIdem_conj refine Eq.trans ?_ hc.symm rw [symPowIdem, symmetriser, map_smul, map_sum] simp only [modPowAlg_single] - show (((Nat.factorial (k + 1) : ℂ))⁻¹ • + change (((Nat.factorial (k + 1) : ℂ))⁻¹ • ∑ σ : Equiv.Perm (Fin (k + 1)), (modPowPerm (A := A) (X := (tensorLeftMod A L.obj R).X) (k + 1) σ : diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleGenerator.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleGenerator.lean index c469150dea..532a4b132b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleGenerator.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleGenerator.lean @@ -54,19 +54,19 @@ theorem exists_simple_generator_algebra (∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) ∧ Nonempty (freeMod 𝔹 ((indOf : C ⥤ Ind C).obj X₀) ≅ freeMod 𝔹 (L.mix p q)) := by - letI := linearOfScalarUnit ψ - letI := monoidalLinearOfScalarUnitBraided ψ - letI := linearOfScalarUnit (indScalarUnit ψ) - letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + 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 - letI := hmon - letI := hcomm + let := hmon + let := hcomm obtain ⟨𝔹, hmon', hcomm', π, hne', hepi, hhom, hsimple⟩ := exists_simple_quotient 𝔸 hne - letI := hmon' - letI := hcomm' - haveI := hhom + let := hmon' + let := hcomm' + have := hhom exact ⟨p, q, 𝔸, 𝔹, hmon, hcomm, hmon', hcomm', π, hne', hcp, hepi, hhom, hsimple, ⟨freeModIsoBaseChange 𝔸 𝔹 π e⟩⟩ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimplePoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimplePoint.lean index 252d51eb9e..c5c2ab131e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimplePoint.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimplePoint.lean @@ -47,7 +47,7 @@ theorem bijective_algebraMap_gammaEven gammaEvenField 𝔹 L hsimple hne Function.Bijective (algebraMap ℂ ((gammaAlgebra (Ind C) L 𝔹).even)) := by - letI : Field ((gammaAlgebra (Ind C) L 𝔹).even) := + let : Field ((gammaAlgebra (Ind C) L 𝔹).even) := gammaEvenField 𝔹 L hsimple hne refine ⟨(algebraMap ℂ _).injective, fun g => ?_⟩ obtain ⟨c, hc⟩ := diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleQuotient.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleQuotient.lean index e135750de5..903fa06802 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleQuotient.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleQuotient.lean @@ -96,7 +96,7 @@ theorem isIdeal_bot [SmallCategory C] [MonoidalCategory C] [Abelian C] 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 _ - show (⊥ : Subobject 𝔸).Factors _ + change (⊥ : Subobject 𝔸).Factors _ rw [Subobject.bot_factors_iff_zero, h, MonoidalPreadditive.whiskerLeft_zero, zero_comp] @@ -126,8 +126,8 @@ theorem isProper_iff_ne_top [SmallCategory C] [MonoidalCategory C] MonObj.mul_one] have hs : ((ρ_ 𝔸).inv ≫ (𝔸 ◁ a) ≫ b) ≫ I.arrow = 𝟙 𝔸 := by rw [Category.assoc, Category.assoc, hb, key, Iso.inv_hom_id] - haveI : IsSplitEpi I.arrow := IsSplitEpi.mk' ⟨_, hs⟩ - haveI : IsIso I.arrow := isIso_of_mono_of_isSplitEpi _ + 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.** -/ @@ -218,15 +218,15 @@ theorem isFiltered_subIndex [SmallCategory C] [Abelian C] (hne : s.Nonempty) (hdir : DirectedOn (· ≤ ·) s) : IsFiltered (SubIndex s) := by obtain ⟨x, hx⟩ := hne - haveI : Nonempty (SubIndex s) := ⟨equivShrink ↥s ⟨x, hx⟩⟩ - haveI : IsDirectedOrder (SubIndex s) := by + 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⟩, ?_, ?_⟩ - · show SubIndex.val j ≤ SubIndex.val _ + · change SubIndex.val j ≤ SubIndex.val _ rw [SubIndex.val_index hz]; exact h₁ - · show SubIndex.val k ≤ SubIndex.val _ + · change SubIndex.val k ≤ SubIndex.val _ rw [SubIndex.val_index hz]; exact h₂ exact isFiltered_of_directed_le_nonempty _ @@ -288,7 +288,7 @@ theorem ι_constColimitIso [SmallCategory C] [IsFiltered J] (A : Ind C) (j : J) : colimit.ι ((Functor.const J).obj A) j ≫ (constColimitIso A).hom = 𝟙 A := by - haveI : IsConnected J := IsFiltered.isConnected J + have : IsConnected J := IsFiltered.isConnected J exact Eq.trans (IsColimit.comp_coconePointUniqueUpToIso_hom _ _ _) rfl @@ -298,10 +298,10 @@ 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 - haveI : ∀ j, Mono ((subCocone s).ι.app j) := fun j => + have : ∀ j, Mono ((subCocone s).ι.app j) := fun j => inferInstanceAs (Mono (SubIndex.val j).arrow) - haveI : Mono ((subCocone s).ι) := NatTrans.mono_of_mono_app _ - haveI : Mono (colimMap ((subCocone s).ι)) := by + 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 = @@ -341,7 +341,7 @@ theorem exists_ub_of_directed (hpr : ∀ I ∈ c, IsProper 𝔸 I) : ∃ ub : Subobject 𝔸, IsIdeal 𝔸 ub ∧ IsProper 𝔸 ub ∧ ∀ I ∈ c, I ≤ ub := by - haveI := isFiltered_subIndex hne hdir + 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 _) @@ -366,7 +366,7 @@ theorem exists_ub_of_directed (fun t => (Subobject.mk (subUnionHom c)).Factors t) hj) ?_ exact Subobject.factors_of_le _ (hlej j) (hid _ (SubIndex.val_mem j)) - haveI : Epi + have : Epi (𝔸 ◁ (Subobject.underlyingIso (subUnionHom c)).inv) := inferInstanceAs (Epi ((tensorLeft 𝔸).map _)) have hgoal : (𝔸 ◁ (Subobject.underlyingIso (subUnionHom c)).inv) @@ -439,7 +439,7 @@ source along an epimorphism, they satisfy the algebra laws. -/ one := o mul := m one_mul := by - haveI : Epi (𝟙_ (Ind C) ◁ p) := + 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 ?_ @@ -449,7 +449,7 @@ source along an epimorphism, they satisfy the algebra laws. -/ rw [← Category.assoc, h₁, Category.assoc, hm, ← Category.assoc, MonObj.one_mul, leftUnitor_naturality] mul_one := by - haveI : Epi (p ▷ 𝟙_ (Ind C)) := + 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 ?_ @@ -553,7 +553,7 @@ theorem whiskerRight_quotMulAux (𝔸 : Ind C) [MonObj 𝔸] [IsCommMonObj 𝔸] (𝔪 : Subobject 𝔸) (h𝔪 : IsIdeal 𝔸 𝔪) : (𝔪.arrow ▷ cokernel 𝔪.arrow) ≫ quotMulAux 𝔸 𝔪 h𝔪 = 0 := by - haveI : Epi ((𝔪 : Ind C) ◁ cokernel.π 𝔪.arrow) := + 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, @@ -651,13 +651,13 @@ theorem exists_simple_quotient η[𝔹] ≠ 0 ∧ Epi π ∧ IsMonHom π ∧ (∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) := by obtain ⟨𝔪, hid, hpr, hmax⟩ := exists_maximal_ideal 𝔸 hne - letI : MonObj (cokernel 𝔪.arrow) := quotMonObj 𝔸 𝔪 hid + let : MonObj (cokernel 𝔪.arrow) := quotMonObj 𝔸 𝔪 hid have hmul : (cokernel.π 𝔪.arrow ⊗ₘ cokernel.π 𝔪.arrow) ≫ μ[cokernel 𝔪.arrow] = μ[𝔸] ≫ cokernel.π 𝔪.arrow := tensorHom_π_quotMul 𝔸 𝔪 hid - letI : IsCommMonObj (cokernel 𝔪.arrow) := + let : IsCommMonObj (cokernel 𝔪.arrow) := isCommMonObj_of_epi (cokernel.π 𝔪.arrow) hmul - haveI : IsMonHom (cokernel.π 𝔪.arrow) := ⟨rfl, hmul.symm⟩ + have : IsMonHom (cokernel.π 𝔪.arrow) := ⟨rfl, hmul.symm⟩ refine ⟨cokernel 𝔪.arrow, inferInstance, inferInstance, cokernel.π 𝔪.arrow, ?_, inferInstance, inferInstance, ?_⟩ · intro h0 @@ -715,7 +715,7 @@ theorem exists_simple_quotient cokernel.π 𝔪.arrow = 0 := by rw [hsnd, Category.assoc, Category.assoc, cokernel.condition, comp_zero, comp_zero] - haveI : Epi (pullback.fst I.arrow (cokernel.π 𝔪.arrow)) := + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleScalars.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleScalars.lean index 3bd3a65207..430d720a43 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleScalars.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleScalars.lean @@ -165,7 +165,7 @@ epimorphism. -/ instance epi_imageFactor [SmallCategory C] [Abelian C] {X Y : Ind C} (k : X ⟶ Y) : Epi (imageFactor k) := by - show Epi (factorThruImage k ≫ _) + change Epi (factorThruImage k ≫ _) exact epi_comp _ _ /-! ## Kernel and image are ideals -/ @@ -192,7 +192,7 @@ theorem isIdeal_imageSubobject_of {X : Ind C} (k : X ⟶ R) (θ : R ⊗ X ⟶ X) (hθ : θ ≫ k = (R ◁ k) ≫ μ[R]) : IsIdeal R (Subobject.mk (image.ι k)) := by - haveI : Epi (R ◁ imageFactor k) := + have : Epi (R ◁ imageFactor k) := inferInstanceAs (Epi ((tensorLeft R).map _)) refine factors_of_epi_comp _ (R ◁ imageFactor k) _ ?_ refine factors_of_comm (θ ≫ imageFactor k) ?_ @@ -221,9 +221,9 @@ theorem eq_zero_of_imageSubobject_eq_bot [SmallCategory C] [Abelian C] 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 - haveI : IsIso (Subobject.mk (image.ι k)).arrow := + have : IsIso (Subobject.mk (image.ι k)).arrow := (Subobject.isIso_arrow_iff_eq_top _).2 h - haveI : IsIso (image.ι k) := by + have : IsIso (image.ι k) := by rw [← Subobject.underlyingIso_arrow (image.ι k)] infer_instance have he : Epi (factorThruImage k ≫ image.ι k) := epi_comp _ _ @@ -245,7 +245,7 @@ theorem isIso_mulBy_of_simple IsIso (mulBy R g) := by have hz : mulBy R g ≠ 0 := fun h => hg (eq_zero_of_mulBy_eq_zero R h) - haveI : Mono (mulBy R g) := by + 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 @@ -253,11 +253,11 @@ theorem isIso_mulBy_of_simple have hk := kernelSubobject_arrow' (mulBy R g) rw [ha, comp_zero] at hk exact hk.symm - · haveI : IsIso (kernelSubobject (mulBy R g)).arrow := + · 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 - haveI : Epi (mulBy R g) := by + 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 @@ -276,7 +276,7 @@ theorem exists_inverse_of_simple {g : 𝟙_ (Ind C) ⟶ R} (hg : g ≠ 0) : ∃ g' : 𝟙_ (Ind C) ⟶ R, (λ_ (𝟙_ (Ind C))).inv ≫ gmul g g' = η[R] := by - haveI := isIso_mulBy_of_simple R hsimple hg + 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] @@ -339,8 +339,8 @@ theorem hom_oddLine_eq_zero_of_simple have hzero : gmul f (𝟙 R) = 0 := by rcases hsimple _ hid with h | h · exact eq_zero_of_imageSubobject_eq_bot h - · haveI := epi_of_imageSubobject_eq_top h - haveI : Epi (L.obj ◁ gmul f (𝟙 R)) := + · 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean index c7979f9881..32a3ecf97e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean @@ -93,7 +93,7 @@ theorem exists_section_biprod [Category.{vE} E] [Abelian E] (hT : ∀ {N' : E} (g : T ⟶ N'), Epi g → ∃ s : N' ⟶ T, s ≫ g = 𝟙 N') : ∃ s : N ⟶ (X ⊞ T), s ≫ f = 𝟙 N := by - haveI := hf + have := hf have hg : biprod.inr ≫ f ≫ cokernel.π (biprod.inr ≫ f) = 0 := by rw [← Category.assoc] exact cokernel.condition _ @@ -101,7 +101,7 @@ theorem exists_section_biprod [Category.{vE} E] [Abelian E] biprod.fst ≫ (biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f)) := by refine biprod.hom_ext' _ _ ?_ ?_ <;> simp [hg] - haveI : Epi (biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f)) := by + 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) @@ -110,7 +110,7 @@ theorem exists_section_biprod [Category.{vE} E] [Abelian E] · have hc0 : cokernel.π (biprod.inr ≫ f) = 0 := by refine zero_of_epi_comp f ?_ rw [hfac, hu, Limits.comp_zero] - haveI : Epi (biprod.inr ≫ f) := by + 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, @@ -119,7 +119,7 @@ theorem exists_section_biprod [Category.{vE} E] [Abelian E] refine ⟨s₀ ≫ biprod.inr, ?_⟩ rw [Category.assoc] exact hs₀ - · haveI : IsIso (biprod.inl ≫ f ≫ cokernel.π (biprod.inr ≫ f)) := + · 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) = @@ -154,7 +154,7 @@ theorem exists_section_idxSum [Category.{vE} E] [Abelian E] induction L with | nil => intro _ N f hf - haveI := 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 ?_ @@ -162,7 +162,7 @@ theorem exists_section_idxSum [Category.{vE} E] [Abelian E] exact ⟨0, by rw [Limits.zero_comp, h1]⟩ | cons i L₀ ih => intro hS N f hf - haveI : Simple (S i) := hS i (List.mem_cons_self ..) + 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 => @@ -193,12 +193,12 @@ theorem isIso_iff_hom IsIso f ↔ IsIso f.hom := by constructor · intro h - haveI := h + have := h exact inferInstanceAs (IsIso ((Mod.forget (D := Ind C) 𝔹).map f)) · intro h - haveI := h - haveI : Mono f := (mono_iff_hom 𝔹 f).2 inferInstance - haveI : Epi f := (epi_iff_hom 𝔹 f).2 inferInstance + 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 @@ -214,7 +214,7 @@ theorem isIdeal_mk_hom have harrow : (Subobject.mk g.hom).arrow = (Subobject.underlyingIso g.hom).hom ≫ g.hom := (Iso.inv_comp_eq _).1 (Subobject.underlyingIso_arrow _) - show (Subobject.mk g.hom).Factors + change (Subobject.mk g.hom).Factors ((𝔹 ◁ (Subobject.mk g.hom).arrow) ≫ μ[𝔹]) refine factors_of_comm ((𝔹 ◁ (Subobject.underlyingIso g.hom).hom) ≫ @@ -238,11 +238,11 @@ theorem simple_regularMod (hne : η[𝔹] ≠ 0) : Simple (regularMod 𝔹) := by constructor intro M g hg - haveI := hg - haveI hmono : Mono g.hom := (mono_iff_hom 𝔹 g).1 hg + have := hg + have hmono : Mono g.hom := (mono_iff_hom 𝔹 g).1 hg constructor · intro hiso h0 - haveI := hiso + have := hiso refine hne ?_ have h1 : (𝟙 (regularMod 𝔹) : regularMod 𝔹 ⟶ regularMod 𝔹) = 0 := (IsIso.inv_hom_id g).symm.trans @@ -254,7 +254,7 @@ theorem simple_regularMod 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 - · haveI : IsIso g.hom := (Subobject.isIso_iff_mk_eq_top g.hom).2 h + · have : IsIso g.hom := (Subobject.isIso_iff_mk_eq_top g.hom).2 h exact (isIso_iff_hom 𝔹 g).2 inferInstance end Regular @@ -320,8 +320,8 @@ theorem isIso_of_whiskerRight (L : OddLine (Ind C)) {X Y : Ind C} (f : X ⟶ Y) (h : IsIso (f ▷ L.obj)) : IsIso f := by - haveI := h - haveI : IsIso ((f ▷ L.obj) ▷ L.obj) := + 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 @@ -364,7 +364,7 @@ noncomputable def lineToRegular have h1 := whiskerRight_act L (actLeft 𝔹 M.X) ((α_ 𝔹 𝔹 L.obj).inv ≫ μ[𝔹] ▷ L.obj) g.hom hf have h2 := rot_act L (A := 𝔹) (X := 𝔹) μ[𝔹] - show ((α_ 𝔹 M.X L.obj).inv ≫ actLeft 𝔹 M.X ▷ L.obj) ≫ + 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 ?_ @@ -392,7 +392,7 @@ theorem lineToRegular_eq_zero_iff exact Mod.hom_ext _ _ (L.eq_zero_of_whiskerRight g.hom h2) · intro h refine Mod.hom_ext _ _ ?_ - show (g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom = 0 + 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] @@ -426,32 +426,32 @@ theorem simple_freeMod_oddLine (L : OddLine (Ind C)) (hsimple : ∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) (hne : η[𝔹] ≠ 0) : Simple (freeMod 𝔹 L.obj) := by - haveI := simple_regularMod 𝔹 hsimple hne + have := simple_regularMod 𝔹 hsimple hne constructor intro M g hg - haveI := hg - haveI hgm : Mono g.hom := (mono_iff_hom 𝔹 g).1 hg - haveI hwm : Mono (g.hom ▷ L.obj) := + 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 - haveI hhm : Mono (lineToRegular 𝔹 L g) := by + have hhm : Mono (lineToRegular 𝔹 L g) := by refine mono_of_mono_hom _ ?_ - show Mono ((g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom) + change Mono ((g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom) exact mono_comp' hwm hrotMono constructor · intro hiso h0 - haveI := hiso + 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 - haveI : IsIso (lineToRegular 𝔹 L g) := + have : IsIso (lineToRegular 𝔹 L g) := isIso_of_mono_of_nonzero (fun h => h0 ((lineToRegular_eq_zero_iff 𝔹 L g).1 h)) - haveI : IsIso ((g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom) := + have : IsIso ((g.hom ▷ L.obj) ≫ (L.rot 𝔹).hom) := (isIso_iff_hom 𝔹 (lineToRegular 𝔹 L g)).1 inferInstance - haveI : IsIso (g.hom ▷ L.obj) := + 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 @@ -511,9 +511,9 @@ theorem mono_freeModMap [MonoidalPreadditive C] (𝔹 : Ind C) [MonObj 𝔹] {V W : Ind C} (f : V ⟶ W) (hf : Mono f) : Mono (freeModMap 𝔹 f) := by - haveI := hf + have := hf refine mono_of_mono_hom _ ?_ - show Mono (𝔹 ◁ f) + change Mono (𝔹 ◁ f) exact inferInstanceAs (Mono ((tensorLeft 𝔹).map f)) /-- **The free-module functor preserves epimorphisms.** -/ @@ -522,9 +522,9 @@ theorem epi_freeModMap [MonoidalPreadditive C] (𝔹 : Ind C) [MonObj 𝔹] {V W : Ind C} (f : V ⟶ W) (hf : Epi f) : Epi (freeModMap 𝔹 f) := by - haveI := hf + have := hf refine epi_of_epi_hom _ ?_ - show Epi (𝔹 ◁ f) + change Epi (𝔹 ◁ f) exact inferInstanceAs (Epi ((tensorLeft 𝔹).map f)) /-- **A subobject of an object with free mixed module has a free @@ -538,9 +538,9 @@ theorem exists_mix_of_mono_of_simple {p q : ℕ} (e : freeMod 𝔹 W ≅ freeMod 𝔹 (L.mix p q)) : ∃ p' q' : ℕ, Nonempty (freeMod 𝔹 Y ≅ freeMod 𝔹 (L.mix p' q')) := by - haveI := simple_regularMod 𝔹 hsimple hne - haveI := simple_freeMod_oddLine 𝔹 L hsimple hne - haveI := mono_freeModMap 𝔹 f hf + 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) @@ -558,9 +558,9 @@ theorem exists_mix_of_epi_of_simple {p q : ℕ} (e : freeMod 𝔹 W ≅ freeMod 𝔹 (L.mix p q)) : ∃ p' q' : ℕ, Nonempty (freeMod 𝔹 Y ≅ freeMod 𝔹 (L.mix p' q')) := by - haveI := simple_regularMod 𝔹 hsimple hne - haveI := simple_freeMod_oddLine 𝔹 L hsimple hne - haveI := epi_freeModMap 𝔹 f hf + 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) @@ -595,9 +595,9 @@ theorem exists_section_freeMod_mix (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 - haveI := simple_regularMod 𝔹 hsimple hne - haveI := simple_freeMod_oddLine 𝔹 L hsimple hne - haveI := hf + 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 _ _) @@ -620,7 +620,7 @@ theorem exists_section_of_simple (hepi : Epi (freeModMap 𝔹 g)) : ∃ s : freeMod 𝔹 W ⟶ freeMod 𝔹 V, s ≫ freeModMap 𝔹 g = 𝟙 (freeMod 𝔹 W) := by - haveI := hepi + have := hepi obtain ⟨p, q, ⟨e⟩⟩ := hV obtain ⟨s₀, hs₀⟩ := exists_section_freeMod_mix 𝔹 L hsimple hne p q diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SmallReduction.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SmallReduction.lean index fbb0169b64..090c06518c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SmallReduction.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SmallReduction.lean @@ -58,20 +58,19 @@ def linearOfFullyFaithful (R : Type*) [Semiring R] {B : Type u₁} 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 - show G.map ((hG.preimage (r • G.map f)) ≫ g) = _ + change G.map ((hG.preimage (r • G.map f)) ≫ g) = _ rw [Functor.map_comp, hG.map_preimage] - show _ = G.map (hG.preimage (r • G.map (f ≫ g))) + 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 - show G.map (f ≫ (hG.preimage (r • G.map g))) = _ + change G.map (f ≫ (hG.preimage (r • G.map g))) = _ rw [Functor.map_comp, hG.map_preimage] - show _ = G.map (hG.preimage (r • G.map (f ≫ g))) + 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. -/ -@[implicit_reducible] -def functorLinearOfFullyFaithful (R : Type*) [Semiring R] +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] : @@ -150,8 +149,8 @@ theorem isSubquotientOf_map {A : Type u₁} [Category.{v₁} A] (h : IsSubquotientOf Y Z) : IsSubquotientOf (G.obj Y) (G.obj Z) := by obtain ⟨S, i, p, hi, hp⟩ := h - haveI := hi - haveI := hp + have := hi + have := hp exact ⟨G.obj S, G.map i, G.map p, inferInstance, inferInstance⟩ /-- The subquotient relation transfers along isomorphisms of both @@ -160,8 +159,8 @@ 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 - haveI := hi - haveI := hp + have := hi + have := hp exact ⟨S, i ≫ iZ.hom, p ≫ iY.hom, inferInstance, inferInstance⟩ /-- A fully faithful functor preserving monomorphisms reflects the @@ -207,11 +206,11 @@ 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.Additive] [G.Linear ℂ] + (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 - show Function.Bijective (fun c : ℂ => (c • 𝟙 (𝟙_ B) : 𝟙_ B ⟶ 𝟙_ B)) + 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) ∘ @@ -319,8 +318,7 @@ noncomputable def smallDelignePreadditive attribute [local instance] smallDelignePreadditive /-- The inverse of the transporting equivalence is additive. -/ -@[implicit_reducible] -def smallDeligneInverseAdditive +theorem smallDeligneInverseAdditive [Category.{v} A] [Abelian A] [EssentiallySmall.{v} A] : (smallDeligneEquiv A).inverse.Additive := (smallDeligneEquiv A).fullyFaithfulInverse.additive_ofFullyFaithful @@ -328,8 +326,7 @@ def smallDeligneInverseAdditive attribute [local instance] smallDeligneInverseAdditive /-- The transporting equivalence is additive. -/ -@[implicit_reducible] -def smallDeligneFunctorAdditive +theorem smallDeligneFunctorAdditive [Category.{v} A] [Abelian A] [EssentiallySmall.{v} A] : (smallDeligneEquiv A).functor.Additive := haveI : (smallDeligneEquiv A).symm.functor.Additive := @@ -348,8 +345,7 @@ noncomputable def smallDeligneLinear attribute [local instance] smallDeligneLinear /-- The inverse of the transporting equivalence is ℂ-linear. -/ -@[implicit_reducible] -def smallDeligneInverseLinear +theorem smallDeligneInverseLinear [Category.{v} A] [Abelian A] [Linear ℂ A] [EssentiallySmall.{v} A] : (smallDeligneEquiv A).inverse.Linear ℂ := functorLinearOfFullyFaithful ℂ @@ -358,8 +354,7 @@ def smallDeligneInverseLinear attribute [local instance] smallDeligneInverseLinear /-- The transporting equivalence is ℂ-linear. -/ -@[implicit_reducible] -def smallDeligneFunctorLinear +theorem smallDeligneFunctorLinear [Category.{v} A] [Abelian A] [Linear ℂ A] [EssentiallySmall.{v} A] : (smallDeligneEquiv A).functor.Linear ℂ := haveI : (smallDeligneEquiv A).symm.functor.Linear ℂ := @@ -369,8 +364,7 @@ def smallDeligneFunctorLinear attribute [local instance] smallDeligneFunctorLinear /-- The small model has finite limits. -/ -@[implicit_reducible] -def smallDeligneFiniteLimits +theorem smallDeligneFiniteLimits [Category.{v} A] [Abelian A] [EssentiallySmall.{v} A] : HasFiniteLimits (SmallDeligne A) := ⟨fun _ _ _ => @@ -388,8 +382,7 @@ noncomputable def smallDeligneAbelian attribute [local instance] smallDeligneAbelian /-- The small model has finite biproducts. -/ -@[implicit_reducible] -def smallDeligneBiproducts +theorem smallDeligneBiproducts [Category.{v} A] [Abelian A] [EssentiallySmall.{v} A] : HasFiniteBiproducts (SmallDeligne A) := HasFiniteBiproducts.of_hasFiniteProducts @@ -397,8 +390,7 @@ def smallDeligneBiproducts attribute [local instance] smallDeligneBiproducts /-- The tensor product of the small model is biadditive. -/ -@[implicit_reducible] -def smallDeligneMonoidalPreadditive +theorem smallDeligneMonoidalPreadditive [Category.{v} A] [Abelian A] [MonoidalCategory A] [MonoidalPreadditive A] [EssentiallySmall.{v} A] : MonoidalPreadditive (SmallDeligne A) := @@ -407,8 +399,7 @@ def smallDeligneMonoidalPreadditive attribute [local instance] smallDeligneMonoidalPreadditive /-- The tensor product of the small model is ℂ-bilinear. -/ -@[implicit_reducible] -def smallDeligneMonoidalLinear +theorem smallDeligneMonoidalLinear [Category.{v} A] [Abelian A] [Linear ℂ A] [MonoidalCategory A] [MonoidalPreadditive A] [MonoidalLinear ℂ A] [EssentiallySmall.{v} A] : MonoidalLinear ℂ (SmallDeligne A) := diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean index b7db3ebb6a..8840874285 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean @@ -127,7 +127,7 @@ theorem splitIns_linear (splitOfBase A M M' d ▷ chainBGr A M M' d) ≫ (letI := chainBGrMonObj A M M' d; μ[chainBGr A M M' d]) := by - show actLeft A M.X ≫ splitIns A M M' d = + 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 @@ -268,10 +268,7 @@ theorem splitIns_linear -- Raised budget: linearity of the insertion unfolds the module -- action through the duality datum on one generator. -/-- **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 +private theorem splitIns_dualStage_absorb [Category.{v} D] [MonoidalCategory D] [SymmetricCategory D] [Preadditive D] [MonoidalPreadditive D] [HasFiniteBiproducts D] [HasCoequalizers D] [Linear ℂ D] [MonoidalLinear ℂ D] @@ -283,34 +280,14 @@ theorem splitIns'_linear [∀ 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 - show 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) + (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 - @@ -318,17 +295,13 @@ theorem splitIns'_linear (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] + ((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)) ≫ @@ -459,6 +432,70 @@ theorem splitIns'_linear 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)) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitClosure.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitClosure.lean index 17aef2b1a9..f7dfc24b11 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitClosure.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitClosure.lean @@ -411,10 +411,10 @@ theorem splitsOn_of_generator [SmallCategory C] [MonoidalCategory C] [Abelian C] IsSplit L 𝔸 ((indOf : C ⥤ Ind C).obj Y)) (hgen : TensorGeneratedBy C X) : SplitsOn L 𝔸 (indOf : C ⥤ Ind C) := by - haveI : (indOf (C := C)).Additive := indOf_additive + have : (indOf (C := C)).Additive := indOf_additive intro Y obtain ⟨k, ab, hsq⟩ := hgen Y - show IsSplit L 𝔸 ((indOf : C ⥤ Ind C).obj Y) + change IsSplit L 𝔸 ((indOf : C ⥤ Ind C).obj Y) refine hsub Y _ hsq ?_ refine IsSplit.of_iso L 𝔸 (((indOf : C ⥤ Ind C).mapBiproduct diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitComplement.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitComplement.lean index ff87ad18ad..4809261889 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitComplement.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitComplement.lean @@ -166,7 +166,7 @@ theorem splitComplAct_one (η[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 - letI := baseChangeModObj φ M + 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) = @@ -203,7 +203,7 @@ theorem splitComplAct_mul (α_ 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 - letI := baseChangeModObj φ M + 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) = @@ -374,7 +374,7 @@ noncomputable def splitDecomp · erw [biprod.inr_desc_assoc, Category.comp_id] apply biprod.hom_ext · erw [Category.assoc, biprod.lift_fst, biprod.inr_fst] - haveI : IsSplitMono (splitCoeval A B φ w d hw) := + 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 @@ -625,7 +625,7 @@ noncomputable def splitDecompMod (by exact modBiprodAct_splitDecompInv A B φ v w d hv hw) hom_inv_id := by apply Mod.Hom.ext - show biprod.lift (splitEval A B φ v hv) + 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)) = @@ -633,7 +633,7 @@ noncomputable def splitDecompMod exact (splitDecomp A B φ v w d hv hw p hp hδ).hom_inv_id inv_hom_id := by apply Mod.Hom.ext - show biprod.desc (splitCoeval A B φ w d hw) + 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δ) = diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitEverything.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitEverything.lean index 60e6cb0edb..8aec3cd2fc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitEverything.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitEverything.lean @@ -55,21 +55,21 @@ theorem exists_splitting_simple_algebra (∀ I : Subobject 𝔹, IsIdeal 𝔹 I → I = ⊥ ∨ I = ⊤) ∧ SplitsOn L 𝔹 (indOf : C ⥤ Ind C) ∧ Nonempty (SuperPoint (gammaAlgebra (Ind C) L 𝔹)) := by - letI := linearOfScalarUnit ψ - letI := monoidalLinearOfScalarUnitBraided ψ - letI := linearOfScalarUnit (indScalarUnit ψ) - letI := monoidalLinearOfScalarUnitBraided (indScalarUnit ψ) + 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 - letI := hmonA - letI := hcommA - letI := hmon - letI := hcomm - haveI := hepi + 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 → @@ -77,7 +77,7 @@ theorem exists_splitting_simple_algebra IsSplit L 𝔹 ((indOf : C ⥤ Ind C).obj Y) := by intro Y Z hsq hZ obtain ⟨a, b, ⟨eZ⟩⟩ := hZ - haveI : (indOf (C := C)).Additive := indOf_additive + 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) := diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtract.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtract.lean index 285df30b40..5c07e24ece 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtract.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtract.lean @@ -248,7 +248,7 @@ theorem mul_splitCoeval μ[B] ≫ splitCoeval A B φ w d hw = (B ◁ splitCoeval A B φ w d hw) ≫ baseChangeAct φ M := by - letI := baseChangeModObj φ M + let := baseChangeModObj φ M have hact : (μ[B] ▷ baseChange φ M) ≫ baseChangeAct φ M = (α_ B B (baseChange φ M)).hom ≫ (B ◁ baseChangeAct φ M) ≫ baseChangeAct φ M := @@ -291,7 +291,7 @@ theorem splitCoeval_splitEval refine Eq.trans (whisker_eq _ (whisker_eq _ (splitCoevalCore_splitEval A B φ v w hv hw p hp))) ?_ exact hδ - show ((ρ_ B).inv ≫ + change ((ρ_ B).inv ≫ (B ◁ (η[A] ≫ d.copair ≫ splitCoevalCore A B φ w hw)) ≫ baseChangeAct φ M) ≫ splitEval A B φ v hv = 𝟙 B diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtractDual.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtractDual.lean index 29a6648362..43bfd6f70d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtractDual.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtractDual.lean @@ -117,7 +117,7 @@ theorem mul_splitCoevalDual μ[B] ≫ splitCoevalDual A B φ v d hv = (B ◁ splitCoevalDual A B φ v d hv) ≫ baseChangeAct φ M' := by - letI := baseChangeModObj φ M' + let := baseChangeModObj φ M' have hact : (μ[B] ▷ baseChange φ M') ≫ baseChangeAct φ M' = (α_ B B (baseChange φ M')).hom ≫ (B ◁ baseChangeAct φ M') ≫ baseChangeAct φ M' := @@ -161,7 +161,7 @@ theorem splitCoevalDual_splitEval (splitCoevalCoreDual_splitEval A B φ v w hv hw p hp))) ?_ exact hδ - show ((ρ_ B).inv ≫ + change ((ρ_ B).inv ≫ (B ◁ (η[A] ≫ d.copair ≫ splitCoevalCoreDual A B φ v hv)) ≫ baseChangeAct φ M') ≫ splitEval A B φ w hw = 𝟙 B @@ -335,7 +335,7 @@ theorem splitComplActDual_one (η[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 - letI := baseChangeModObj φ M' + 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) = @@ -372,7 +372,7 @@ theorem splitComplActDual_mul (α_ 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 - letI := baseChangeModObj φ M' + 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) = @@ -548,7 +548,7 @@ noncomputable def splitDecompDual · erw [biprod.inr_desc_assoc, Category.comp_id] apply biprod.hom_ext · erw [Category.assoc, biprod.lift_fst, biprod.inr_fst] - haveI : IsSplitMono (splitCoevalDual A B φ v d hv) := + 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δ⟩ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean index 08fb77c95c..f5248935eb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean @@ -129,7 +129,7 @@ theorem splitOfBase_mul (splitOfBase A M M' d ⊗ₘ splitOfBase A M M' d) ≫ (letI := chainBGrMonObj A M M' d; μ[chainBGr A M M' d]) := by - show μ[A] ≫ splitOfBase A M M' d = + 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 ?_ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitPairDef.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitPairDef.lean index 771519b53d..ba7639cad0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitPairDef.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitPairDef.lean @@ -73,7 +73,7 @@ theorem modTensorπ_splitPairMul (splitIns A M M' d ⊗ₘ splitIns' A M M' d) ≫ (letI := chainBGrMonObj A M M' d; μ[chainBGr A M M' d]) := by - show modTensorπ A M M' ≫ splitPairMul A M M' d = + 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' @@ -86,7 +86,7 @@ theorem modTensorπ_splitPairMul 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 - show modTensorπ A M M' ≫ chainPairMul A M M' d ≫ + 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) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitTransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitTransport.lean index ce39ef1915..5cfd120e78 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitTransport.lean @@ -66,7 +66,7 @@ theorem baseChangeFreeIso_inv_natural baseChangeMapMod A B φ (freeModMap A f) := by apply Mod.Hom.ext rw [Mod.comp_hom', Mod.comp_hom'] - show (B ◁ f) ≫ baseChangeFreeInv A B φ W = + change (B ◁ f) ≫ baseChangeFreeInv A B φ W = baseChangeFreeInv A B φ V ≫ (baseChangeMapMod A B φ (freeModMap A f)).hom exact baseChangeFreeInv_natural A B φ f diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepA.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepA.lean index 0f18ea0cee..414cf04762 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepA.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepA.lean @@ -39,13 +39,13 @@ theorem devissageStepA (L : OddLine (Ind C)) (X : Ind C) : DevissageStepA (Ind C) L X := by intro st hSym - letI := st.monObj - letI := st.comm + 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 - letI := sd.monObj - letI := sd.comm - letI := sd.ofBase_monHom + let := sd.monObj + let := sd.comm + let := sd.ofBase_monHom obtain ⟨e⟩ := st.decomp refine ⟨{ base := sd.carrier monObj := sd.monObj diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepATransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepATransport.lean index f5887f9a8f..5a7bd4bc20 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepATransport.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepATransport.lean @@ -68,14 +68,14 @@ noncomputable def baseChangeMapIso exact baseChangeAct_modTensorMap A B φ e.inv) hom_inv_id := by apply Mod.Hom.ext - show modTensorMap A (𝟙 (restrictRegular φ)) e.hom ≫ + 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 - show modTensorMap A (𝟙 (restrictRegular φ)) e.inv ≫ + 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, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepB.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepB.lean index d3aa97c3cf..8b7a2a3cf9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepB.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepB.lean @@ -40,8 +40,8 @@ theorem devissageStepB (L : OddLine (Ind C)) (X : Ind C) : DevissageStepB (Ind C) L X := by intro st hAlt - letI := st.monObj - letI := st.comm + 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Letters.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Letters.lean index ccc25668fe..9c0798e1cf 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Letters.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Letters.lean @@ -326,7 +326,7 @@ private theorem normIso_inv_succ [Category.{v} A] [MonoidalCategory A] (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 - show (whiskerRightIso (normIso U n (w ∘ Fin.castSucc)) _ ≪≫ + 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, @@ -341,7 +341,7 @@ private theorem normIso_hom_succ [Category.{v} A] [MonoidalCategory A] (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 - show (whiskerRightIso (normIso U n (w ∘ Fin.castSucc)) _ ≪≫ + 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] @@ -486,7 +486,7 @@ theorem permIndex_extPerm_castSucc {K : Type*} {n : ℕ} permIndex (extPerm τ) c ∘ Fin.castSucc = permIndex τ (c ∘ Fin.castSucc) := by funext j - show c ((extPerm τ)⁻¹ (Fin.castSucc j)) = c (Fin.castSucc (τ⁻¹ 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 @@ -494,7 +494,7 @@ 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 - show c ((extPerm τ)⁻¹ (Fin.last n)) = c (Fin.last n) + change c ((extPerm τ)⁻¹ (Fin.last n)) = c (Fin.last n) rw [extPerm_inv, extPerm_last] /-- The top transposition is its own inverse. -/ @@ -507,7 +507,7 @@ 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 - show c (topSwap⁻¹ (Fin.last (n + 1))) = _ + change c (topSwap⁻¹ (Fin.last (n + 1))) = _ rw [topSwap_inv, topSwap_last] /-- Reindexing along the top transposition, second letter. -/ @@ -515,7 +515,7 @@ 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 - show c (topSwap⁻¹ (Fin.castSucc (Fin.last n))) = _ + change c (topSwap⁻¹ (Fin.castSucc (Fin.last n))) = _ rw [topSwap_inv, topSwap_castSucc_last] /-- Reindexing along the top transposition, lower letters. -/ @@ -524,7 +524,7 @@ theorem permIndex_topSwap_low {K : Type*} {n : ℕ} permIndex topSwap c ∘ Fin.castSucc ∘ Fin.castSucc = c ∘ Fin.castSucc ∘ Fin.castSucc := by funext j - show c (topSwap⁻¹ (Fin.castSucc (Fin.castSucc j))) = _ + change c (topSwap⁻¹ (Fin.castSucc (Fin.castSucc j))) = _ rw [topSwap_inv, topSwap_castSucc_castSucc] rfl @@ -1268,15 +1268,15 @@ theorem nIn_permAlg_nOut Linear.smul_comp, smul_smul, Linear.smul_comp] rw [hstep] by_cases hpop : popCount (par ∘ c) = popCount (par ∘ d) - · rw [dif_pos hpop, colourSum, Finset.sum_filter, + · 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 [if_pos hσ, Linear.smul_comp, Category.assoc, + · rw [ite_eq_left hσ, Linear.smul_comp, Category.assoc, S.nIn_nOut_of_eq hσ, eqToHom_trans] - · rw [if_neg hσ, Linear.smul_comp, Category.assoc, + · rw [ite_eq_right hσ, Linear.smul_comp, Category.assoc, S.nIn_nOut_ne n hσ, Limits.comp_zero, smul_zero, zero_smul] - · rw [dif_neg hpop] + · rw [dite_eq_right hpop] refine Finset.sum_eq_zero fun σ _ => ?_ have hσ : permIndex σ c ≠ d := fun hcd => hpop (by rw [← hcd] @@ -1312,7 +1312,7 @@ theorem colourSum_eq_zero (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, dif_pos hpop] at h0 + 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)) ⟶ @@ -1357,9 +1357,9 @@ theorem permAlg_eq_zero _ = 0 := by rw [S.nIn_permAlg_nOut hβ x c d] by_cases hpop : popCount (par ∘ c) = popCount (par ∘ d) - · rw [dif_pos hpop, hx c d, zero_smul, Limits.zero_comp, + · rw [dite_eq_left hpop, hx c d, zero_smul, Limits.zero_comp, Limits.comp_zero] - · rw [dif_neg hpop, 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Signs.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Signs.lean index 9195df9f1a..7899874c15 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Signs.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Signs.lean @@ -112,7 +112,7 @@ 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] - show w i = true ↔ permIndex σ w (σ i) = true + change w i = true ↔ permIndex σ w (σ i) = true rw [permIndex_apply_self] /-- The shift, applied. -/ @@ -292,7 +292,7 @@ private theorem oddPerm_swap_of_both {n : ℕ} {w : Fin (n + 1) → Bool} swap_mem_trueSet ha hb (trueEnum w xa).2⟩ : {j // j ∈ trueSet w}) = ⟨i.succ, mem_trueSet.mpr hb⟩ := by refine Subtype.ext ?_ - show s ((trueEnum w xa : Fin (n + 1))) = i.succ + 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] @@ -306,7 +306,7 @@ private theorem oddPerm_swap_of_both {n : ℕ} {w : Fin (n + 1) → Bool} swap_mem_trueSet ha hb (trueEnum w xb).2⟩ : {j // j ∈ trueSet w}) = ⟨i.castSucc, mem_trueSet.mpr ha⟩ := by refine Subtype.ext ?_ - show s ((trueEnum w xb : Fin (n + 1))) = i.castSucc + 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] @@ -330,7 +330,7 @@ private theorem oddPerm_swap_of_both {n : ℕ} {w : Fin (n + 1) → Bool} swap_mem_trueSet ha hb (trueEnum w x).2⟩ : {j // j ∈ trueSet w}) = trueEnum w x := by refine Subtype.ext ?_ - show s ((trueEnum w x : Fin (n + 1))) = + 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'] @@ -408,14 +408,14 @@ 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 [if_pos hab, parSign, oddPerm_swap_of_both hab.1 hab.2, + · 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 [if_neg hab, parSign, oddPerm_swap_of_not hab, + · rw [ite_eq_right hab, parSign, oddPerm_swap_of_not hab, Equiv.Perm.sign_one] norm_num diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean index fdf5f85096..bfceae6825 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean @@ -204,7 +204,7 @@ theorem sumPow_total [Category.{v} A] [Preadditive A] [HasBinaryBiproducts A] intro k induction k with | zero => - show (∑ i : Fin 1, sumPowPrj X 0 i ≫ sumPowIns X 0 i) = + change (∑ i : Fin 1, sumPowPrj X 0 i ≫ sumPowIns X 0 i) = 𝟙 (sumPow X 0) rw [Fin.sum_univ_one] exact Category.id_comp _ @@ -235,12 +235,12 @@ noncomputable def mixedSumLetters ins_prj k := by cases k with | inl i => - show (sumPowIns (𝟙_ A) p i ≫ biprod.inl) ≫ + 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 => - show (sumPowIns U q j ≫ biprod.inr) ≫ + 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 @@ -249,25 +249,25 @@ noncomputable def mixedSumLetters | inl i => cases k' with | inl i' => - show (sumPowIns (𝟙_ A) p i ≫ biprod.inl) ≫ + 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' => - show (sumPowIns (𝟙_ A) p i ≫ biprod.inl) ≫ + 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' => - show (sumPowIns U q j ≫ biprod.inr) ≫ + 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' => - show (sumPowIns U q j ≫ biprod.inr) ≫ + 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 @@ -298,7 +298,7 @@ noncomputable def mixedSumLetters Preadditive.comp_sum] refine Finset.sum_congr rfl fun j _ => ?_ simp only [Category.assoc] - show (∑ i : Fin (p + 1), + change (∑ i : Fin (p + 1), ((biprod.fst : sumPow (𝟙_ A) p ⊞ sumPow U q ⟶ _) ≫ sumPowPrj (𝟙_ A) p i) ≫ (sumPowIns (𝟙_ A) p i ≫ @@ -420,7 +420,7 @@ private theorem prodMap_smul₂ {M₁ M₂ N₁ N₂ : Type*} instance : MonoidalPreadditive SuperVect where whiskerLeft_zero {X Y Z} := by apply SuperVect.hom_ext - · show LinearMap.prodMap + · change LinearMap.prodMap (TensorProduct.map LinearMap.id (SuperVect.Hom.evenMap (0 : Y ⟶ Z))) (TensorProduct.map LinearMap.id @@ -430,7 +430,7 @@ instance : MonoidalPreadditive SuperVect where TensorProduct.map_zero_right, TensorProduct.map_zero_right, prodMap_zero₂] rfl - · show LinearMap.prodMap + · change LinearMap.prodMap (TensorProduct.map LinearMap.id (SuperVect.Hom.oddMap (0 : Y ⟶ Z))) (TensorProduct.map LinearMap.id @@ -442,7 +442,7 @@ instance : MonoidalPreadditive SuperVect where rfl zero_whiskerRight {X Y Z} := by apply SuperVect.hom_ext - · show LinearMap.prodMap + · change LinearMap.prodMap (TensorProduct.map (SuperVect.Hom.evenMap (0 : Y ⟶ Z)) LinearMap.id) (TensorProduct.map (SuperVect.Hom.oddMap (0 : Y ⟶ Z)) @@ -452,7 +452,7 @@ instance : MonoidalPreadditive SuperVect where TensorProduct.map_zero_left, TensorProduct.map_zero_left, prodMap_zero₂] rfl - · show LinearMap.prodMap + · change LinearMap.prodMap (TensorProduct.map (SuperVect.Hom.evenMap (0 : Y ⟶ Z)) LinearMap.id) (TensorProduct.map (SuperVect.Hom.oddMap (0 : Y ⟶ Z)) @@ -464,7 +464,7 @@ instance : MonoidalPreadditive SuperVect where rfl whiskerLeft_add {X Y Z} f g := by apply SuperVect.hom_ext - · show LinearMap.prodMap + · change LinearMap.prodMap (TensorProduct.map LinearMap.id (SuperVect.Hom.evenMap (f + g))) (TensorProduct.map LinearMap.id @@ -474,7 +474,7 @@ instance : MonoidalPreadditive SuperVect where TensorProduct.map_add_right, TensorProduct.map_add_right, prodMap_add₂] rfl - · show LinearMap.prodMap + · change LinearMap.prodMap (TensorProduct.map LinearMap.id (SuperVect.Hom.oddMap (f + g))) (TensorProduct.map LinearMap.id @@ -486,7 +486,7 @@ instance : MonoidalPreadditive SuperVect where rfl add_whiskerRight {X Y Z} f g := by apply SuperVect.hom_ext - · show LinearMap.prodMap + · change LinearMap.prodMap (TensorProduct.map (SuperVect.Hom.evenMap (f + g)) LinearMap.id) (TensorProduct.map (SuperVect.Hom.oddMap (f + g)) @@ -496,7 +496,7 @@ instance : MonoidalPreadditive SuperVect where TensorProduct.map_add_left, TensorProduct.map_add_left, prodMap_add₂] rfl - · show LinearMap.prodMap + · change LinearMap.prodMap (TensorProduct.map (SuperVect.Hom.evenMap (f + g)) LinearMap.id) (TensorProduct.map (SuperVect.Hom.oddMap (f + g)) @@ -511,7 +511,7 @@ instance : MonoidalPreadditive SuperVect where instance : MonoidalLinear ℂ SuperVect where whiskerLeft_smul X Y Z r f := by apply SuperVect.hom_ext - · show LinearMap.prodMap + · change LinearMap.prodMap (TensorProduct.map LinearMap.id (SuperVect.Hom.evenMap (r • f))) (TensorProduct.map LinearMap.id @@ -521,7 +521,7 @@ instance : MonoidalLinear ℂ SuperVect where TensorProduct.map_smul_right, TensorProduct.map_smul_right, prodMap_smul₂] rfl - · show LinearMap.prodMap + · change LinearMap.prodMap (TensorProduct.map LinearMap.id (SuperVect.Hom.oddMap (r • f))) (TensorProduct.map LinearMap.id @@ -533,7 +533,7 @@ instance : MonoidalLinear ℂ SuperVect where rfl smul_whiskerRight r {Y Z} f X := by apply SuperVect.hom_ext - · show LinearMap.prodMap + · change LinearMap.prodMap (TensorProduct.map (SuperVect.Hom.evenMap (r • f)) LinearMap.id) (TensorProduct.map (SuperVect.Hom.oddMap (r • f)) @@ -543,7 +543,7 @@ instance : MonoidalLinear ℂ SuperVect where TensorProduct.map_smul_left, TensorProduct.map_smul_left, prodMap_smul₂] rfl - · show LinearMap.prodMap + · change LinearMap.prodMap (TensorProduct.map (SuperVect.Hom.evenMap (r • f)) LinearMap.id) (TensorProduct.map (SuperVect.Hom.oddMap (r • f)) @@ -592,8 +592,7 @@ private theorem tensor_zero_right_eq {M : Type*} [AddCommGroup M] /-- 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.induction_on with - | zero => simp + induction b using TensorProduct.inductionOn with | add x y hx hy => rw [map_add, hx, hy] | tmul v w => have hrep : ∀ v : Fin 1 → ℂ, @@ -623,14 +622,14 @@ theorem stdSuper_braiding_neg : apply SuperVect.hom_ext · apply LinearMap.ext rintro ⟨a, b⟩ - show ((TensorProduct.comm ℂ (Fin 0 → ℂ) (Fin 0 → ℂ)) a, + 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⟩ - show ((TensorProduct.comm ℂ (Fin 1 → ℂ) (Fin 0 → ℂ)) y, + change ((TensorProduct.comm ℂ (Fin 1 → ℂ) (Fin 0 → ℂ)) y, (TensorProduct.comm ℂ (Fin 0 → ℂ) (Fin 1 → ℂ)) x) = (-x, -y) exact Prod.ext (hEO _ _) (hOE _ _) @@ -761,11 +760,11 @@ noncomputable def stdSuperLetters (p q : ℕ) : cases k with | inl i => apply SuperVect.hom_ext - · show (LinearMap.proj (R := ℂ) (φ := fun _ : Fin (p + 1) => ℂ) + · change (LinearMap.proj (R := ℂ) (φ := fun _ : Fin (p + 1) => ℂ) i).comp (LinearMap.single ℂ (fun _ => ℂ) i) = LinearMap.id refine LinearMap.ext fun z => ?_ - show Pi.single (M := fun _ : Fin (p + 1) => ℂ) i z i = 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) _ _ @@ -773,14 +772,14 @@ noncomputable def stdSuperLetters (p q : ℕ) : apply SuperVect.hom_ext · refine LinearMap.ext fun z => ?_ exact Subsingleton.elim (α := Fin 0 → ℂ) _ _ - · show (LinearMap.pi fun _ : Fin 1 => + · 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 - show Pi.single (M := fun _ : Fin (q + 1) => ℂ) j (v 0) j = + 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 @@ -789,10 +788,10 @@ noncomputable def stdSuperLetters (p q : ℕ) : cases k' with | inl i' => apply SuperVect.hom_ext - · show (LinearMap.proj (R := ℂ) (φ := fun _ : Fin (p + 1) => ℂ) + · change (LinearMap.proj (R := ℂ) (φ := fun _ : Fin (p + 1) => ℂ) i').comp (LinearMap.single ℂ (fun _ => ℂ) i) = 0 refine LinearMap.ext fun z => ?_ - show Pi.single (M := fun _ : Fin (p + 1) => ℂ) i z i' = 0 + 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 => ?_ @@ -802,7 +801,7 @@ noncomputable def stdSuperLetters (p q : ℕ) : · refine LinearMap.ext fun z => ?_ exact Subsingleton.elim (α := Fin 0 → ℂ) _ _ · refine LinearMap.ext fun z => ?_ - show (LinearMap.pi fun _ : Fin 1 => + change (LinearMap.pi fun _ : Fin 1 => LinearMap.proj (R := ℂ) (φ := fun _ : Fin (q + 1) => ℂ) j') ((0 : PUnit →ₗ[ℂ] (Fin (q + 1) → ℂ)) z) = 0 @@ -812,7 +811,7 @@ noncomputable def stdSuperLetters (p q : ℕ) : | inl i' => apply SuperVect.hom_ext · refine LinearMap.ext fun z => ?_ - show (LinearMap.proj (R := ℂ) + change (LinearMap.proj (R := ℂ) (φ := fun _ : Fin (p + 1) => ℂ) i') ((0 : (Fin 0 → ℂ) →ₗ[ℂ] (Fin (p + 1) → ℂ)) z) = 0 rfl @@ -822,14 +821,14 @@ noncomputable def stdSuperLetters (p q : ℕ) : apply SuperVect.hom_ext · refine LinearMap.ext fun z => ?_ exact Subsingleton.elim (α := Fin 0 → ℂ) _ _ - · show (LinearMap.pi fun _ : Fin 1 => + · 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 - show Pi.single (M := fun _ : Fin (q + 1) => ℂ) j (v 0) j' + 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEvenRing.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEvenRing.lean index 4ab1760b91..c932a70f11 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEvenRing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEvenRing.lean @@ -58,10 +58,10 @@ instance instModuleEvenOdd : Module S.even S.odd where 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 - show S.mulEO (x + y) u = S.mulEO x u + S.mulEO y u + 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 - show S.mulEO 0 u = 0 + 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 @@ -70,7 +70,7 @@ even argument. -/ instance instIsScalarTowerComplexEvenOdd : IsScalarTower ℂ S.even S.odd where smul_assoc r x u := by - show S.mulEO (r • x) u = r • S.mulEO x u + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGamma.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGamma.lean index 164c0b1911..173a0333a1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGamma.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGamma.lean @@ -304,59 +304,59 @@ def superGammaAlgebra [Category.{u'} D] [MonoidalCategory D] [BraidedCategory D] mulOE := convAlongHom R (ρ_ o).inv mulOO := convAlongHom R ho.inv one_mul_e := fun x => by - show convAlong R (λ_ (𝟙_ D)).inv η x = x + change convAlong R (λ_ (𝟙_ D)).inv η x = x exact convAlong_one_left R x one_mul_o := fun u => by - show convAlong R (λ_ o).inv η u = u + change convAlong R (λ_ o).inv η u = u exact convAlong_one_left R u assoc_eee := fun x y z => by - show convAlong R (λ_ (𝟙_ D)).inv + 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 - show convAlong R (λ_ o).inv + 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 - show convAlong R (ρ_ o).inv + 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 - show convAlong R ho.inv (convAlong R (λ_ o).inv x u) v = + 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 - show convAlong R (ρ_ o).inv + 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 - show convAlong R ho.inv (convAlong R (ρ_ o).inv u x) v = + 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 - show convAlong R (λ_ (𝟙_ D)).inv + 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 - show convAlong R (λ_ o).inv (convAlong R ho.inv u v) w = + 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 - show convAlong R (λ_ (𝟙_ D)).inv x y = + 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 - show convAlong R (λ_ o).inv x u = convAlong R (ρ_ o).inv u x + 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 - show convAlong R ho.inv u v = -convAlong R ho.inv v u + change convAlong R ho.inv u v = -convAlong R ho.inv v u exact convAlong_oo_comm R ho hβ u v end OddLine diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean index baa86b50f3..af4b8954f0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean @@ -448,7 +448,7 @@ private theorem superOddSquare_inv_evenMap_one : superOddSquare.inv.evenMap (1 : ℂ) = ((0 : (Fin 0 → ℂ) ⊗[ℂ] (Fin 0 → ℂ)), oddGen ⊗ₜ[ℂ] oddGen) := by - show (prodZeroEquiv ((Fin 0 → ℂ) ⊗[ℂ] (Fin 0 → ℂ)) + change (prodZeroEquiv ((Fin 0 → ℂ) ⊗[ℂ] (Fin 0 → ℂ)) ((Fin 1 → ℂ) ⊗[ℂ] (Fin 1 → ℂ)) ≪≫ₗ lineTensorEquiv).symm.toLinearMap (1 : ℂ) = _ have hg : (LinearEquiv.funUnique (Fin 1) ℂ ℂ).symm 1 = oddGen := @@ -476,7 +476,7 @@ private theorem line_pair_swap (x : Fin 1 → ℂ) : x 0 • (0, oddGen ⊗ₜ[ℂ] oddGen) := by refine Prod.ext ?_ ?_ · exact Subsingleton.elim _ _ - · show oddGen ⊗ₜ[ℂ] (x 0 • oddGen) = + · change oddGen ⊗ₜ[ℂ] (x 0 • oddGen) = x 0 • (oddGen ⊗ₜ[ℂ] oddGen) rw [TensorProduct.tmul_smul] conv_lhs => rw [oddGen_rep x] @@ -583,16 +583,16 @@ def superVectScalarUnit : ℂ ≃+* End (𝟙_ SuperVect) where toFun c := ⟨c • (LinearMap.id : ℂ →ₗ[ℂ] ℂ), 0⟩ invFun f := unitEvenMap f 1 left_inv c := by - show (c • (LinearMap.id : ℂ →ₗ[ℂ] ℂ)) 1 = c + change (c • (LinearMap.id : ℂ →ₗ[ℂ] ℂ)) 1 = c simp right_inv f := by apply SuperVect.hom_ext - · show (unitEvenMap f 1) • (LinearMap.id : ℂ →ₗ[ℂ] ℂ) = + · 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 - show unitEvenMap f 1 * z = _ + change unitEvenMap f 1 * z = _ rw [smul_eq_mul, mul_comm] _ = unitEvenMap f (z • 1) := (map_smul (unitEvenMap f) z 1).symm @@ -601,16 +601,16 @@ def superVectScalarUnit : ℂ ≃+* End (𝟙_ SuperVect) where · exact Subsingleton.elim _ _ map_mul' a b := by apply SuperVect.hom_ext - · show (a * b) • (LinearMap.id : ℂ →ₗ[ℂ] ℂ) = + · change (a * b) • (LinearMap.id : ℂ →ₗ[ℂ] ℂ) = (a • (LinearMap.id : ℂ →ₗ[ℂ] ℂ)) ∘ₗ (b • (LinearMap.id : ℂ →ₗ[ℂ] ℂ)) refine LinearMap.ext fun z => ?_ - show (a * b) * z = a * (b * z) + change (a * b) * z = a * (b * z) rw [mul_assoc] · exact Subsingleton.elim _ _ map_add' a b := by apply SuperVect.hom_ext - · show (a + b) • (LinearMap.id : ℂ →ₗ[ℂ] ℂ) = + · change (a + b) • (LinearMap.id : ℂ →ₗ[ℂ] ℂ) = a • (LinearMap.id : ℂ →ₗ[ℂ] ℂ) + b • (LinearMap.id : ℂ →ₗ[ℂ] ℂ) exact add_smul a b _ @@ -653,7 +653,7 @@ trivialization it was pulled back from. -/ theorem smallComparison_square : smallComparison.square sOdd smallOddSquare = superOddSquare := by refine Iso.ext ?_ - show (Functor.Monoidal.μIso smallSuperInclusion sOdd sOdd).hom ≫ + change (Functor.Monoidal.μIso smallSuperInclusion sOdd sOdd).hom ≫ smallSuperInclusion.map smallOddSquare.hom ≫ (Functor.Monoidal.εIso smallSuperInclusion).inv = superOddSquare.hom diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModAbelian.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModAbelian.lean index 1ce29420d4..ff1bdf1604 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModAbelian.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModAbelian.lean @@ -175,7 +175,7 @@ theorem quotientMap_spec have hs : (LinearMap.quotKerEquivOfSurjective φ hφ).symm (φ e) = Submodule.Quotient.mk e := LinearMap.quotKerEquivOfSurjective_symm_apply φ hφ e - show Submodule.liftQ (LinearMap.ker φ) g (ker_le_ker g φ h) + change Submodule.liftQ (LinearMap.ker φ) g (ker_le_ker g φ h) ((LinearMap.quotKerEquivOfSurjective φ hφ).symm (φ e)) = g e rw [hs] rfl diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprodMap.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprodMap.lean index 648ff1d52c..bc082c832f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprodMap.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprodMap.lean @@ -41,11 +41,11 @@ theorem bijective_evenMap {M N : S.Mod} (e : M ≅ N) : refine Function.bijective_iff_has_inverse.mpr ⟨e.inv.evenMap, ?_, ?_⟩ · intro m - show (e.hom ≫ e.inv).evenMap m = m + change (e.hom ≫ e.inv).evenMap m = m rw [e.hom_inv_id] rfl · intro n - show (e.inv ≫ e.hom).evenMap n = n + change (e.inv ≫ e.hom).evenMap n = n rw [e.inv_hom_id] rfl @@ -55,11 +55,11 @@ theorem bijective_oddMap {M N : S.Mod} (e : M ≅ N) : refine Function.bijective_iff_has_inverse.mpr ⟨e.inv.oddMap, ?_, ?_⟩ · intro m - show (e.hom ≫ e.inv).oddMap m = m + change (e.hom ≫ e.inv).oddMap m = m rw [e.hom_inv_id] rfl · intro n - show (e.inv ≫ e.hom).oddMap n = n + change (e.inv ≫ e.hom).oddMap n = n rw [e.inv_hom_id] rfl diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModHom.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModHom.lean index 6e1898e94a..334987c503 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModHom.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModHom.lean @@ -58,19 +58,19 @@ def Hom.comp {M N P : S.Mod} (f : Hom M N) (g : Hom N P) : evenMap := g.evenMap.comp f.evenMap oddMap := g.oddMap.comp f.oddMap map_actEE x m := by - show g.evenMap (f.evenMap _) = _ + change g.evenMap (f.evenMap _) = _ rw [f.map_actEE, g.map_actEE] rfl map_actEO x m := by - show g.oddMap (f.oddMap _) = _ + change g.oddMap (f.oddMap _) = _ rw [f.map_actEO, g.map_actEO] rfl map_actOE u m := by - show g.oddMap (f.oddMap _) = _ + change g.oddMap (f.oddMap _) = _ rw [f.map_actOE, g.map_actOE] rfl map_actOO u m := by - show g.evenMap (f.evenMap _) = _ + change g.evenMap (f.evenMap _) = _ rw [f.map_actOO, g.map_actOO] rfl @@ -186,9 +186,9 @@ instance instPreadditive : Preadditive S.Mod where add_comp _ _ _ f f' g := by refine Hom.ext (LinearMap.ext fun x => ?_) (LinearMap.ext fun x => ?_) - · show g.evenMap (f.evenMap x + f'.evenMap x) = _ + · change g.evenMap (f.evenMap x + f'.evenMap x) = _ exact map_add _ _ _ - · show g.oddMap (f.oddMap x + f'.oddMap x) = _ + · change g.oddMap (f.oddMap x + f'.oddMap x) = _ exact map_add _ _ _ comp_add _ _ _ f g g' := Hom.ext rfl rfl diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModMonoidal.lean index 9964ebef47..ca80528bf1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModMonoidal.lean @@ -926,10 +926,10 @@ noncomputable def leftUnitor : S.unitMod.tensor M ≅ M where inv_hom_id := by refine Hom.ext (LinearMap.ext fun m => ?_) (LinearMap.ext fun m => ?_) - · show (leftUnitorHom M).evenMap (tmulEE S.unitMod M S.one m) = m + · change (leftUnitorHom M).evenMap (tmulEE S.unitMod M S.one m) = m rw [leftUnitorHom_evenMap_tmulEE] exact M.one_act_e m - · show (leftUnitorHom M).oddMap (tmulEO S.unitMod M S.one m) = m + · change (leftUnitorHom M).oddMap (tmulEO S.unitMod M S.one m) = m rw [leftUnitorHom_oddMap_tmulEO] exact M.one_act_o m @@ -1062,11 +1062,11 @@ noncomputable def rightUnitor : M.tensor S.unitMod ≅ M where inv_hom_id := by refine Hom.ext (LinearMap.ext fun m => ?_) (LinearMap.ext fun m => ?_) - · show (rightUnitorHom M).evenMap + · change (rightUnitorHom M).evenMap (tmulEE M S.unitMod m S.one) = m rw [rightUnitorHom_evenMap_tmulEE] exact M.one_act_e m - · show (rightUnitorHom M).oddMap + · change (rightUnitorHom M).oddMap (tmulOE M S.unitMod m S.one) = m rw [rightUnitorHom_oddMap_tmulOE] exact M.one_act_o m diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShiftUnit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShiftUnit.lean index cd6636845e..456404dd6c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShiftUnit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShiftUnit.lean @@ -86,44 +86,44 @@ def shiftUnitData : TensorData (shift S.unitMod) M (shift M) where feo := -M.actOO foe := M.actEE hee := fun b m n => by - show M.actOE (S.mulEO b m) n = M.actOE m (M.actEE b n) + 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 - show -M.actEO (S.mulEE b m) n = -M.actEO m (M.actEO b n) + 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 - show -M.actEO (S.mulOO c m) n = M.actOE m (M.actOO c n) + 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 - show M.actOE (S.mulOE c m) n + 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 - show -M.actOO (S.mulEO b m) n = -M.actOO m (M.actEO b n) + 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 - show M.actEE (S.mulEE b m) n = M.actEE m (M.actEE b n) + 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 - show M.actEE (S.mulOO c m) n = -(M.actOO m (M.actOE c n)) + 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 - show -M.actOO (S.mulOE c m) n = -(M.actEE m (M.actOO c n)) + 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 - show -M.actEO (S.mulEE a m) n = M.actEO a (-(M.actEO m n)) + 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 - show -M.actOO (S.mulEO a m) n = M.actEE a (-(M.actOO m n)) + 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 - show -M.actOO (S.mulOE c m) n = M.actOO c (-(M.actEO m n)) + 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 - show -M.actEO (S.mulOO c m) n = M.actOE c (-(M.actOO m n)) + 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 @@ -166,18 +166,18 @@ noncomputable def shiftUnitInv : evenMap := -tmulOO (shift S.unitMod) M S.one oddMap := tmulOE (shift S.unitMod) M S.one map_actEE x m := by - show -(tmulOO (shift S.unitMod) M S.one (M.actEO x m)) + 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 - show tmulOE (shift S.unitMod) M S.one (M.actEE x m) + 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 - show tmulOE (shift S.unitMod) M S.one (M.actOO v m) + 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] @@ -185,7 +185,7 @@ noncomputable def shiftUnitInv : 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 - show -(tmulOO (shift S.unitMod) M S.one (M.actOE v m)) + 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] @@ -231,7 +231,7 @@ noncomputable def shiftUnitTensor : inv_hom_id := by refine Hom.ext (LinearMap.ext fun m => ?_) (LinearMap.ext fun m => ?_) - · show (shiftUnitHom M).evenMap + · change (shiftUnitHom M).evenMap (-(tmulOO (shift S.unitMod) M S.one m)) = m refine Eq.trans (map_neg _ _) ?_ refine Eq.trans (congrArg Neg.neg diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModTensor.lean index f62f945152..9bbe7edb9e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModTensor.lean @@ -862,7 +862,7 @@ theorem actEO_tmulOE (a : S.even) (m : M.odd) (n : N.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 - show Submodule.Quotient.mk + 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) @@ -873,7 +873,7 @@ theorem actOE_tmulEE (c : S.odd) (m : M.even) (n : N.even) : 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 - show Submodule.Quotient.mk + 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) @@ -884,7 +884,7 @@ theorem actOE_tmulOO (c : S.odd) (m : M.odd) (n : N.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 - show Submodule.Quotient.mk + 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) @@ -895,7 +895,7 @@ theorem actOO_tmulEO (c : S.odd) (m : M.even) (n : N.odd) : 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 - show Submodule.Quotient.mk + 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) @@ -996,7 +996,7 @@ theorem liftEven_tmulEE (m : M.even) (n : N.even) : liftEven M N fee foo hee hoo hoeo hooe (tmulEE M N m n) = fee m n := by - show TensorProduct.lift fee (m ⊗ₜ[ℂ] n) + change TensorProduct.lift fee (m ⊗ₜ[ℂ] n) + TensorProduct.lift foo 0 = fee m n rw [map_zero, add_zero, TensorProduct.lift.tmul] @@ -1016,7 +1016,7 @@ theorem liftEven_tmulOO (m : M.odd) (n : N.odd) : liftEven M N fee foo hee hoo hoeo hooe (tmulOO M N m n) = foo m n := by - show TensorProduct.lift fee 0 + change TensorProduct.lift fee 0 + TensorProduct.lift foo (m ⊗ₜ[ℂ] n) = foo m n rw [map_zero, zero_add, TensorProduct.lift.tmul] @@ -1036,7 +1036,7 @@ theorem liftOdd_tmulEO (m : M.even) (n : N.odd) : liftOdd M N feo foe heeo heoe hoee hooo (tmulEO M N m n) = feo m n := by - show TensorProduct.lift feo (m ⊗ₜ[ℂ] n) + change TensorProduct.lift feo (m ⊗ₜ[ℂ] n) + TensorProduct.lift foe 0 = feo m n rw [map_zero, add_zero, TensorProduct.lift.tmul] @@ -1056,7 +1056,7 @@ theorem liftOdd_tmulOE (m : M.odd) (n : N.even) : liftOdd M N feo foe heeo heoe hoee hooo (tmulOE M N m n) = foe m n := by - show TensorProduct.lift feo 0 + change TensorProduct.lift feo 0 + TensorProduct.lift foe (m ⊗ₜ[ℂ] n) = foe m n rw [map_zero, zero_add, TensorProduct.lift.tmul] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperPointMod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperPointMod.lean index dc9f6f29ec..3a69a26876 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperPointMod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperPointMod.lean @@ -53,27 +53,27 @@ noncomputable def pointMod (P : SuperPoint S) : actOO := 0 one_act_e m := by refine ULift.ext _ _ ?_ - show P.chi 1 * m.down = m.down + 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 _ _ ?_ - show P.chi (S.mulEE x y) * m.down = P.chi x * (P.chi y * m.down) + 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 _ _ ?_ - show (0 : ℂ) = P.chi x * (0 : ULift.{w} ℂ).down + change (0 : ℂ) = P.chi x * (0 : ULift.{w} ℂ).down simp assoc_oee _ _ _ := Subsingleton.elim _ _ assoc_oeo x u m := by refine ULift.ext _ _ ?_ - show (0 : ℂ) = (0 : ULift.{w} ℂ).down + change (0 : ℂ) = (0 : ULift.{w} ℂ).down rfl assoc_ooe u v m := by refine ULift.ext _ _ ?_ - show P.chi (S.mulOO u v) * m.down = (0 : ULift.{w} ℂ).down + change P.chi (S.mulOO u v) * m.down = (0 : ULift.{w} ℂ).down rw [P.vanishing, zero_mul]; rfl assoc_ooo _ _ _ := Subsingleton.elim _ _ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean index 9460a27d45..fce29bae24 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean @@ -160,10 +160,10 @@ instance instCommRingEven : CommRing S.even := one := S.one left_distrib := fun x y z => map_add (S.mulEE x) y z right_distrib := fun x y z => by - show S.mulEE (x + y) z = S.mulEE x z + S.mulEE y z + 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 - show S.mulEE 0 x = 0 + 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 @@ -183,7 +183,7 @@ the even-even block. -/ instance instAlgebraEven : Algebra ℂ S.even := Algebra.ofModule (fun r x y => by - show S.mulEE (r • x) y = r • S.mulEE x y + 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) @@ -415,15 +415,15 @@ componentwise. -/ instance instPreadditive : Preadditive SuperMod.{u} where add_comp _ _ _ f f' g := by apply Hom.ext - · show g.evenMap ∘ₗ (f.evenMap + f'.evenMap) = _ + · change g.evenMap ∘ₗ (f.evenMap + f'.evenMap) = _ exact LinearMap.comp_add _ _ _ - · show g.oddMap ∘ₗ (f.oddMap + f'.oddMap) = _ + · change g.oddMap ∘ₗ (f.oddMap + f'.oddMap) = _ exact LinearMap.comp_add _ _ _ comp_add _ _ _ f g g' := by apply Hom.ext - · show (g.evenMap + g'.evenMap) ∘ₗ f.evenMap = _ + · change (g.evenMap + g'.evenMap) ∘ₗ f.evenMap = _ exact LinearMap.add_comp _ _ _ - · show (g.oddMap + g'.oddMap) ∘ₗ f.oddMap = _ + · change (g.oddMap + g'.oddMap) ∘ₗ f.oddMap = _ exact LinearMap.add_comp _ _ _ /-- SuperMod is ℂ-linear: composition is ℂ-bilinear @@ -431,15 +431,15 @@ componentwise. -/ instance instLinear : CategoryTheory.Linear ℂ SuperMod.{u} where smul_comp _ _ _ c f g := by apply Hom.ext - · show g.evenMap ∘ₗ (c • f.evenMap) = _ + · change g.evenMap ∘ₗ (c • f.evenMap) = _ exact LinearMap.comp_smul _ _ _ - · show g.oddMap ∘ₗ (c • f.oddMap) = _ + · change g.oddMap ∘ₗ (c • f.oddMap) = _ exact LinearMap.comp_smul _ _ _ comp_smul _ _ _ f c g := by apply Hom.ext - · show (c • g.evenMap) ∘ₗ f.evenMap = _ + · change (c • g.evenMap) ∘ₗ f.evenMap = _ exact LinearMap.smul_comp _ _ _ - · show (c • g.oddMap) ∘ₗ f.oddMap = _ + · change (c • g.oddMap) ∘ₗ f.oddMap = _ exact LinearMap.smul_comp _ _ _ /-- Even elements of a zero super module vanish: the identity @@ -533,7 +533,7 @@ theorem indOf_hom_eq_zero (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 - haveI : (indOf (C := C)).Additive := indOf_additive + 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] @@ -559,7 +559,7 @@ 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 - haveI : HasZeroObject C := hasZeroObject_of_hasInitial_object + 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 => @@ -571,7 +571,7 @@ theorem isZero_ind_of_hom_eq_zero have hsubF : ∀ X : C, Subsingleton (((Ind.inclusion C).obj F).obj (op X)) := by intro X - haveI : Subsingleton (indOf.obj X ⟶ F) := + 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 @@ -579,7 +579,7 @@ theorem isZero_ind_of_hom_eq_zero Subsingleton (((Ind.inclusion C).obj (indOf.obj (0 : C))).obj (op X)) := by intro X - haveI : Subsingleton (indOf.obj X ⟶ indOf.obj (0 : C)) := + 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 ≅ @@ -593,10 +593,10 @@ theorem isZero_ind_of_hom_eq_zero exact Equiv.toIso (equivOfSubsingletonOfSubsingleton (fun _ => e (indOf.obj (0 : C)) X.unop 0) (fun _ => e F X.unop 0)) - · haveI : Subsingleton + · have : Subsingleton (((Ind.inclusion C).obj (indOf.obj (0 : C))).obj Y) := hsub0 Y.unop - haveI : Subsingleton (((Ind.inclusion C).obj F).obj X ⟶ + 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 @@ -688,7 +688,7 @@ theorem unitHomMul_assoc R ◁ R ◁ c ≫ R ◁ μ[R] ≫ μ[R] := by rw [rightUnitor_inv_naturality_assoc, ← whisker_exchange_assoc, MonObj.mul_assoc, associator_naturality_right_assoc] - simp [unitHomMul, tensorHom_def] + simp? [unitHomMul, tensorHom_def] rw [← unitors_equal] simp only [Iso.inv_hom_id_assoc] rw [key] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSeries.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSeries.lean index d1de5dc4ef..f290a7461d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSeries.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSeries.lean @@ -92,7 +92,7 @@ private theorem one_add_X_mul_alt : | zero => simp | succ m => rw [coeff_succ_X_mul, coeff_mk, coeff_mk, coeff_one, - if_neg (Nat.succ_ne_zero m), pow_succ] + ite_eq_right (Nat.succ_ne_zero m), pow_succ] ring private theorem powerSumSeries_superPS_eq (p q : ℕ) : diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSmall.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSmall.lean index ad6399271c..d47e8a730d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSmall.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSmall.lean @@ -176,19 +176,19 @@ def piBicone {n : ℕ} (f : Fin n → SuperVect) : Bicone f where LinearMap.single ℂ (fun i => (f i).odd) j⟩ ι_π j j' := by rcases eq_or_ne j j' with rfl | hne - · rw [dif_pos rfl, eqToHom_refl] + · rw [dite_eq_left rfl, eqToHom_refl] refine hom_ext (LinearMap.ext fun x => ?_) (LinearMap.ext fun x => ?_) - · show Pi.single (M := fun i => (f i).even) j x j = 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 - · show Pi.single (M := fun i => (f i).odd) j x 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 [dif_neg hne] + · rw [dite_eq_right hne] refine hom_ext (LinearMap.ext fun x => ?_) (LinearMap.ext fun x => ?_) - · show Pi.single (M := fun i => (f i).even) j x j' = 0 + · 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 - · show Pi.single (M := fun i => (f i).odd) j x j' = 0 + · 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. -/ @@ -338,7 +338,7 @@ theorem evenLineIn_comp_prj_same (p q : ℕ) (i : Fin p) : refine hom_ext (LinearMap.ext fun x => funext fun k => ?_) (Subsingleton.elim _ _) obtain rfl : k = 0 := Subsingleton.elim k 0 - show Pi.single (M := fun _ : Fin 1 => ℂ) 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] @@ -347,7 +347,7 @@ 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 _ _) - show Pi.single (M := fun _ : Fin 1 => ℂ) 0 + 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 @@ -359,7 +359,7 @@ theorem oddLineIn_comp_prj_same (p q : ℕ) (j : Fin q) : refine hom_ext (Subsingleton.elim _ _) (LinearMap.ext fun x => funext fun k => ?_) obtain rfl : k = 0 := Subsingleton.elim k 0 - show Pi.single (M := fun _ : Fin 1 => ℂ) 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] @@ -368,7 +368,7 @@ 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 => ?_) - show Pi.single (M := fun _ : Fin 1 => ℂ) 0 + 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 @@ -391,7 +391,7 @@ theorem evenLinePrj_comp_in_evenMap (p q : ℕ) (i : Fin p) : LinearMap.single ℂ (fun _ : Fin p => ℂ) i ∘ₗ LinearMap.proj (φ := fun _ : Fin p => ℂ) i := by refine LinearMap.ext fun x => funext fun k => ?_ - show Pi.single (M := fun _ : Fin p => ℂ) i + 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] @@ -410,7 +410,7 @@ theorem oddLinePrj_comp_in_oddMap (p q : ℕ) (j : Fin q) : LinearMap.single ℂ (fun _ : Fin q => ℂ) j ∘ₗ LinearMap.proj (φ := fun _ : Fin q => ℂ) j := by refine LinearMap.ext fun x => funext fun k => ?_ - show Pi.single (M := fun _ : Fin q => ℂ) j + 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] @@ -559,26 +559,26 @@ def genBicone (p q : ℕ) : Bicone (genFamily p q) where ι_π s t := by rcases s with i | j <;> rcases t with i' | j' · rcases eq_or_ne i i' with rfl | hne - · rw [dif_pos rfl, eqToHom_refl] + · rw [dite_eq_left rfl, eqToHom_refl] exact InducedCategory.hom_ext (SuperVect.evenLineIn_comp_prj_same p q i) - · rw [dif_neg fun h => hne (Sum.inl.inj h)] + · 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 [dif_neg (Sum.inl_ne_inr)] + · 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 [dif_neg (Sum.inr_ne_inl)] + · 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 [dif_pos rfl, eqToHom_refl] + · rw [dite_eq_left rfl, eqToHom_refl] exact InducedCategory.hom_ext (SuperVect.oddLineIn_comp_prj_same p q j) - · rw [dif_neg fun h => hne (Sum.inr.inj h)] + · 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 @@ -608,7 +608,7 @@ theorem biproductGenerates_smallSuper : intro X obtain ⟨p, q⟩ := X refine ⟨p + q, fun j => genWord p q (finSumFinEquiv.symm j), ?_⟩ - haveI : HasBiproduct (genFamily p q) := + have : HasBiproduct (genFamily p q) := HasBiproduct.mk ⟨genBicone p q, genBiconeIsBilimit p q⟩ exact ⟨biproduct.uniqueUpToIso (genFamily p q) (genBiconeIsBilimit p q) ≪≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean index ffbd70f23c..9a2af897dc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean @@ -104,7 +104,7 @@ theorem sTr_conj {V W : SuperVect} (e : V ≅ W) (f : V ⟶ V) : product of endomorphisms. -/ theorem sTr_tensorHom {V W : SuperVect} (f : V ⟶ V) (g : W ⟶ W) : sTr (f ⊗ₘ g) = sTr f * sTr g := by - show sTr (SuperVect.tensorHom f g) = sTr f * sTr g + 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) @@ -168,7 +168,7 @@ theorem parPow_evenMap (V : SuperVect) (n : ℕ) : induction n with | zero => rfl | succ n ih => - show ((parPow V n) ≫ parHom V).evenMap = _ + change ((parPow V n) ≫ parHom V).evenMap = _ rw [SuperVect.cat_comp_evenMap, parHom_evenMap, ih] rfl @@ -178,7 +178,7 @@ theorem parPow_oddMap (V : SuperVect) (n : ℕ) : induction n with | zero => simp [parPow, SuperVect.cat_id_oddMap] | succ n ih => - show ((parPow V n) ≫ parHom V).oddMap = _ + change ((parPow V n) ≫ parHom V).oddMap = _ rw [SuperVect.cat_comp_oddMap, parHom_oddMap, ih, pow_succ] ext v simp @@ -245,8 +245,8 @@ theorem totTensor_tmul (V W : SuperVect) (x : Tot V) (y : Tot W) : ((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, LinearEquiv.prodCongr_apply, - TensorProduct.prodLeft_tmul, TensorProduct.prodRight_tmul] + simp only [totTensor, LinearEquiv.trans_apply, + TensorProduct.prodLeft_tmul] rfl /-- **Naturality of the total tensor identification**: the total map @@ -259,10 +259,10 @@ theorem tot_tensorHom {V₁ V₂ W₁ W₂ : SuperVect} (TensorProduct.map (tot f) (tot g)) := by apply TensorProduct.ext' intro x y - show tot (f ⊗ₘ g) (totTensor V₁ W₁ (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] - show tot (SuperVect.tensorHom f g) _ = _ + change tot (SuperVect.tensorHom f g) _ = _ simp only [tot, SuperVect.tensorHom_evenMap, SuperVect.tensorHom_oddMap, LinearMap.prodMap_apply] rfl @@ -314,11 +314,10 @@ theorem tot_associator (V W Z : SuperVect) : := by apply TensorProduct.ext' intro u z - induction u using TensorProduct.induction_on with - | zero => simp + induction u using TensorProduct.inductionOn with | add a b ha hb => simp only [TensorProduct.add_tmul, map_add, ha, hb] | tmul x y => - show tot (α_ V W Z).hom + change tot (α_ V W Z).hom (totTensor (SuperVect.tensorObj V W) Z (TensorProduct.map (totTensor V W).toLinearMap LinearMap.id ((x ⊗ₜ y) ⊗ₜ z))) = @@ -331,12 +330,12 @@ theorem tot_associator (V W Z : SuperVect) : LinearMap.id_apply, LinearEquiv.coe_coe, LinearEquiv.coe_coe, totTensor_tmul, totTensor_tmul, totTensor_tmul, totTensor_tmul] - show (LinearMap.prodMap + 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] - show ((SuperVect.assocEvenEquiv V W Z) _, + 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 @@ -394,7 +393,7 @@ theorem tot_koszulBraiding (V W : SuperVect) : obtain ⟨x1, x2⟩ := x have hx : ((x1, x2) : Tot V) = (x1, 0) + (0, x2) := by rw [Prod.mk_add_mk, add_zero, zero_add] - show tot (β_ V W).hom (totTensor V W ((x1, x2) ⊗ₜ y)) = + 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₂ (· + ·) ?_ ?_ @@ -403,7 +402,7 @@ theorem tot_koszulBraiding (V W : SuperVect) : rw [show ((0, 0) : Tot V) = 0 from rfl, TensorProduct.tmul_zero, add_zero, TensorProduct.zero_tmul, TensorProduct.zero_tmul, totTensor_tmul] - show (SuperVect.koszulBraidingEven V W (x1 ⊗ₜ y.1, 0), + 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] @@ -412,7 +411,7 @@ theorem tot_koszulBraiding (V W : SuperVect) : rw [show ((0, 0) : Tot V) = 0 from rfl, TensorProduct.tmul_zero, zero_add, TensorProduct.zero_tmul, TensorProduct.zero_tmul, totTensor_tmul] - show (SuperVect.koszulBraidingEven V W (0, x2 ⊗ₜ y.2), + 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, @@ -486,8 +485,7 @@ theorem trace_flip_twist -- equivalence obtain ⟨T, rfl⟩ := (homTensorHomEquiv ℂ U V U V).surjective G rw [homTensorHomEquiv_apply] - induction T using TensorProduct.induction_on with - | zero => simp + 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, @@ -511,8 +509,7 @@ theorem trace_flip_twist (TensorProduct.assoc ℂ U V V).toLinearMap)) := by apply TensorProduct.ext' intro w z - induction w using TensorProduct.induction_on with - | zero => simp + induction w using TensorProduct.inductionOn with | add w₁ w₂ h₁ h₂ => rw [TensorProduct.add_tmul, map_add, map_add, h₁, h₂] | tmul u v => @@ -553,12 +550,57 @@ private theorem trace_comp_comm_monoid {M N : Type*} [Module.Free ℂ N] [Module.Finite ℂ N] (f : M →ₗ[ℂ] N) (g : N →ₗ[ℂ] M) : LinearMap.trace ℂ M (g ∘ₗ f) = LinearMap.trace ℂ N (f ∘ₗ g) := by - letI : AddCommGroup M := Module.addCommMonoidToAddCommGroup ℂ - letI : AddCommGroup N := Module.addCommMonoidToAddCommGroup ℂ + let : AddCommGroup M := Module.addCommMonoidToAddCommGroup ℂ + let : AddCommGroup N := Module.addCommMonoidToAddCommGroup ℂ exact LinearMap.trace_comp_comm' f g -- Raised budget: 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 @@ -599,7 +641,7 @@ theorem sTr_swap_conj (P X : SuperVect) have hbeta : ∀ x, tot (P ◁ (β_ X X).hom) (J'lin x) = J'lin (TensorProduct.map LinearMap.id (signedFlip X X) x) := by intro x - show tot (P ◁ (β_ X X).hom) + 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)) @@ -619,7 +661,7 @@ theorem sTr_swap_conj (P X : SuperVect) have hgconj : (tot g).comp TP.toLinearMap = TP.toLinearMap.comp g' := by refine LinearMap.ext fun y => ?_ - show tot g (TP y) = TP (g' y) + change tot g (TP y) = TP (g' y) rw [hg'] simp have hwhiskg : ∀ y, tot (g ▷ X) (TA y) = @@ -630,7 +672,7 @@ theorem sTr_swap_conj (P X : SuperVect) have hgstep : ∀ x, tot (g ▷ X) (Jlin x) = Jlin (TensorProduct.map g' LinearMap.id x) := by intro x - show tot (g ▷ 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)) @@ -646,7 +688,7 @@ theorem sTr_swap_conj (P X : SuperVect) have hhstep : ∀ x, tot (SuperVect.tensorObj P X ◁ h) (Jlin x) = Jlin (TensorProduct.map LinearMap.id (tot h) x) := by intro x - show tot (SuperVect.tensorObj P X ◁ h) + 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)) @@ -685,7 +727,7 @@ theorem sTr_swap_conj (P X : SuperVect) (g ▷ X) ≫ (SuperVect.tensorObj P X ◁ h)) = (JE.toLinearMap.comp C').comp JE.symm.toLinearMap := by refine LinearMap.ext fun z => ?_ - show tot _ z = JE (C' (JE.symm 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) : @@ -741,10 +783,10 @@ theorem sTr_swap_conj (P X : SuperVect) ((tot (parHom X)).comp (tot h)).comp (totOddProj X) = tot k := by refine LinearMap.ext fun x => ?_ - show (tot h ((x.1, 0) : Tot X)) + + change (tot h ((x.1, 0) : Tot X)) + tot (parHom X) (tot h ((0, x.2) : Tot X)) = tot k x rw [hk] - show ((SuperVect.Hom.evenMap h x.1, SuperVect.Hom.oddMap h 0) + 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) = @@ -763,38 +805,7 @@ theorem sTr_swap_conj (P X : SuperVect) rw [← LinearMap.comp_add, ← TensorProduct.map_add_right, hkey] rw [← map_add, hsum] -- identify the right-hand side - 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'] + have hRHS := sTr_comp_whiskerLeft_total P X g k rw [htrace1, htrace3, hRHS] /-! ## The trace of the standard cycles @@ -816,11 +827,11 @@ theorem sTr_insertTop_full (X : SuperVect) : intro h erw [show insertTop X 0 0 = 𝟙 _ from insertTop_zero X 0, Category.id_comp] - show sTr (𝟙 (tensorPow SuperVect X 0) ⊗ₘ h) = _ + 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 ℂ] - haveI : Subsingleton (tensorPow SuperVect X 0).odd := + 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 _ _] @@ -847,7 +858,7 @@ theorem sTr_permMor_topCycle_zero (X : SuperVect) (n : ℕ) : have h2 : insertTop X n n ≫ (tensorPow SuperVect X n ◁ (𝟙 X)) = insertTop X n n := by rw [MonoidalCategory.whiskerLeft_id] - show insertTop X n n ≫ 𝟙 (tensorPow SuperVect X (n + 1)) = _ + 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] @@ -919,7 +930,7 @@ theorem cycleType_viaEmbedding {α β : Type*} (e : Equiv.Perm α) (ι : α ↪ β) : (e.viaEmbedding ι).cycleType = e.cycleType := by rw [Equiv.Perm.viaEmbedding] - letI : DecidablePred (· ∈ Set.range ι.toFun) := + let : DecidablePred (· ∈ Set.range ι.toFun) := fun a => Classical.propDecidable _ exact Equiv.Perm.cycleType_extendDomain _ @@ -1043,14 +1054,14 @@ theorem superChar_nfPerm (p q : ℕ) : ∀ cs : List ℕ, induction cs with | nil => intro _ - show superChar p q 0 1 = (List.map (fun c => superPS p q c) + 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 ℂ] - haveI : Subsingleton + have : Subsingleton (tensorPow SuperVect (stdSuper p q) 0).odd := inferInstanceAs (Subsingleton PUnit) rw [show Module.finrank ℂ @@ -1156,7 +1167,7 @@ theorem sTr_permAlg_e (P : SchurPackage.{0}) (p q : ℕ) L (MonoidAlgebra.of ℂ (Equiv.Perm (Fin lam.card)) π) = cycleFun (superPS p q) π := by intro π - show sTrL _ (permAlg (stdSuper p q) lam.card + 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, @@ -1220,7 +1231,7 @@ def gradedSignRep (p q n : ℕ) : toFun σ := tot (permMor (stdSuper p q) n σ) map_one' := by rw [permMor_one, tot_id]; rfl map_mul' σ τ := by - show tot (permMor (stdSuper p q) n (σ * τ)) = _ + change tot (permMor (stdSuper p q) n (σ * τ)) = _ rw [permMor_mul, tot_comp] rfl @@ -1237,7 +1248,7 @@ theorem gradedSignRep_asAlgebraHom (p q n : ℕ) tot (permAlg (stdSuper p q) n z) := by induction z using MonoidAlgebra.induction_on with | of σ => - show (gradedSignRep p q n).asAlgebraHom + change (gradedSignRep p q n).asAlgebraHom (MonoidAlgebra.single σ (1 : ℂ)) = tot (permAlg (stdSuper p q) n (MonoidAlgebra.single σ (1 : ℂ))) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymAlg.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymAlg.lean index 69eda2620c..1965245940 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymAlg.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymAlg.lean @@ -205,7 +205,7 @@ theorem tensorPowConcat_peel [Category.{v} D] [MonoidalCategory D] (X : D) | 0 => by rw [tensorPowConcat_succ X p 0, powPeel_zero, tensorPowConcat_zero, tensorPowConcat_zero] - simp only [Iso.trans_hom, Iso.symm_hom, whiskerRightIso_hom] + 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)) ≫ @@ -1493,8 +1493,8 @@ private theorem winFrame_adjSwap_low (tensorPowConcat X (a + 2) (q + 1)) hCb simp only [winFrame, winAssemble, adjSwapMor, swapTop, Category.assoc] at h0 ⊢ - simp only [tensorPow, tensorPowConcat, Iso.trans_inv, whiskerRightIso_inv, - Iso.symm_inv, winAssemble, 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymDatum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymDatum.lean index 8f8ffa7668..ed068279b8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymDatum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymDatum.lean @@ -45,20 +45,20 @@ noncomputable def ModDualityDatum.transfer pair := modTensorMap A s' s ≫ d.pair copair := d.copair ≫ modTensorMap A r r' pair_linear := by - letI := modTensorModObj A Q' Q - letI := modTensorModObj A P' P + 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 - show modTensorAct A Q' Q ≫ modTensorMap A s' s ≫ d.pair = + 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 - letI := modTensorModObj A Q Q' - letI := modTensorModObj A P P' + 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 - show μ[A] ≫ d.copair ≫ modTensorMap A r r' = + 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, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean index fd9125e656..0ef4b8c786 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean @@ -108,7 +108,7 @@ theorem tensorPowConcat_assoc [Category.{v} D] [MonoidalCategory D] (X : D) (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] - show ((tensorPowConcat X p q).hom ▷ + change ((tensorPowConcat X p q).hom ▷ (tensorPow D X r ⊗ X)) ≫ (powExpose X (p + q) r ≫ ((tensorPowConcat X (p + q) r).hom ▷ X)) = @@ -120,7 +120,6 @@ theorem tensorPowConcat_assoc [Category.{v} D] [MonoidalCategory D] (X : D) ((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] at hstep repeat' erw [Category.assoc] rw [MonoidalCategory.associator_inv_naturality_left_assoc, ← MonoidalCategory.comp_whiskerRight, @@ -139,7 +138,7 @@ theorem tensorPowConcat_zero_left | 0 => by have hc : powCast X (by omega : 0 = 0 + 0) = 𝟙 _ := rfl rw [tensorPowConcat_zero, hc, Category.comp_id] - show (ρ_ (𝟙_ D)).hom = (λ_ (𝟙_ D)).hom + change (ρ_ (𝟙_ D)).hom = (λ_ (𝟙_ D)).hom rw [← unitors_equal] | n + 1 => by have hcast : powCast X (by omega : n + 1 = 0 + (n + 1)) = @@ -150,7 +149,7 @@ theorem tensorPowConcat_zero_left (λ_ (tensorPow D X n ⊗ X)).hom := by monoidal rw [tensorPowConcat_succ_hom X 0 n, tensorPowConcat_zero_left X n] - show (α_ (𝟙_ D) (tensorPow D X n) X).inv ≫ + 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 ≫ @@ -893,7 +892,7 @@ theorem symmetriser_mul_mapDomain {k N : ℕ} rw [symmetriser, map_smul, map_sum] congr 1 refine Finset.sum_congr rfl fun σ _ => ?_ - show MonoidAlgebra.mapDomain _ _ = _ + change MonoidAlgebra.mapDomain _ _ = _ exact MonoidAlgebra.mapDomain_single rw [hmap, mul_smul_comm, Finset.mul_sum] simp only [symmetriser_mul_single] @@ -1013,10 +1012,10 @@ section ZeroPow /-- At arity zero the symmetriser is the unit of the group algebra. -/ theorem symmetriser_zero : symmetriser 0 = 1 := by - letI : Unique (Equiv.Perm (Fin 0)) := + let : Unique (Equiv.Perm (Fin 0)) := ⟨⟨1⟩, fun σ => Equiv.ext fun x => x.elim0⟩ rw [symmetriser, Fintype.sum_unique] - show ((Nat.factorial 0 : ℂ))⁻¹ • + 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 @@ -1045,10 +1044,10 @@ noncomputable def symPowZero /-- At arity one the symmetriser is the unit of the group algebra. -/ theorem symmetriser_one : symmetriser 1 = 1 := by - letI : Unique (Equiv.Perm (Fin 1)) := + let : Unique (Equiv.Perm (Fin 1)) := ⟨⟨1⟩, fun σ => Equiv.ext fun x => Subsingleton.elim _ _⟩ rw [symmetriser, Fintype.sum_unique] - show ((Nat.factorial 1 : ℂ))⁻¹ • + 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 @@ -1217,7 +1216,7 @@ theorem symPowZero_inv_symPowσ [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 - show ((modPowZero A X).inv ≫ symPowπ A X 0) ≫ symPowσ A X 0 = + 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] @@ -1484,7 +1483,7 @@ theorem braiding_one_pow_exists permMor X (n + 1) τ | 0 => ⟨1, by rw [powPeel_zero, permMor_one] - show ((λ_ X).hom ≫ (ρ_ X).inv) ≫ (β_ X (𝟙_ D)).hom = + 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]⟩ @@ -1571,7 +1570,7 @@ theorem tensorPowConcat_braiding_exists | 0 => ⟨1, by rw [permMor_one, Category.comp_id, tensorPowConcat_zero, tensorPowConcat_zero_left] - show (β_ (𝟙_ D) (tensorPow D X n)).hom ≫ + change (β_ (𝟙_ D) (tensorPow D X n)).hom ≫ (ρ_ (tensorPow D X n)).hom = ((λ_ (tensorPow D X n)).hom ≫ powCast X (by omega : n = 0 + n)) ≫ @@ -1717,3 +1716,5 @@ theorem symMul_comm 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 index 9363a3b7a5..135b28da3f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorDatum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorDatum.lean @@ -44,7 +44,7 @@ noncomputable def interchangeDesc (interchange A X₁ X₂ Y₁ Y₂) (by rw [modTensorLegM, modTensorLegN, actRight] - show ((β_ (modTensor A X₁ X₂) A).hom ≫ + 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 ≫ @@ -89,7 +89,7 @@ theorem interchangeDesc_act modTensorπ_interchangeDesc] conv_rhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc, modTensorπ_interchangeDesc] - show (α_ A (modTensor A X₁ X₂) (modTensor A Y₁ Y₂)).inv ≫ + 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₂) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorTransfer.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorTransfer.lean index 840c9be907..d7d3decdcb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorTransfer.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorTransfer.lean @@ -47,7 +47,7 @@ noncomputable def whiskerLeftAlg map_zero' := MonoidalPreadditive.whiskerLeft_zero map_add' f g := MonoidalPreadditive.whiskerLeft_add f g commutes' c := by - show P ◁ (c • 𝟙 X) = c • 𝟙 (P ⊗ X) + change P ◁ (c • 𝟙 X) = c • 𝟙 (P ⊗ X) rw [MonoidalLinear.whiskerLeft_smul, MonoidalCategory.whiskerLeft_id] @@ -63,11 +63,11 @@ noncomputable def pairPermHom 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 - show permMor X n 1 ⊗ₘ permMor Y n 1 = + 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 - show permMor X n (g.1 * h.1) ⊗ₘ permMor Y n (g.2 * h.2) = + 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, @@ -111,13 +111,13 @@ theorem pairAlg_diagEmbed 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 _ _) - show pairAlg X Y n (diagEmbed (MonoidAlgebra.single σ 1)) = + 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 - show MonoidAlgebra.mapDomain _ (MonoidAlgebra.single σ 1) = _ + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single σ 1) = _ exact MonoidAlgebra.mapDomain_single rw [hd, pairAlg_single, diagAlg_single] exact DFunLike.congr_fun hext x @@ -138,7 +138,7 @@ theorem pairAlg_extFst (whiskerAlg (tensorPow A X n) (tensorPow A Y n)).comp (permAlg X n) := by refine MonoidAlgebra.algHom_ext (fun σ => ?_) (Subsingleton.elim _ _) - show pairAlg X Y n (MonoidAlgebra.mapDomainAlgHom ℂ ℂ + 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)) @@ -147,7 +147,7 @@ theorem pairAlg_extFst MonoidAlgebra.single ((σ, 1) : Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) (1 : ℂ) := by - show MonoidAlgebra.mapDomain _ (MonoidAlgebra.single σ 1) = _ + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single σ 1) = _ exact MonoidAlgebra.mapDomain_single rw [hf, pairAlg_single, permAlg_single, permMor_one, MonoidalCategory.tensorHom_id] @@ -170,7 +170,7 @@ theorem pairAlg_extSnd (whiskerLeftAlg (tensorPow A X n) (tensorPow A Y n)).comp (permAlg Y n) := by refine MonoidAlgebra.algHom_ext (fun τ => ?_) (Subsingleton.elim _ _) - show pairAlg X Y n (MonoidAlgebra.mapDomainAlgHom ℂ ℂ + 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)) @@ -179,7 +179,7 @@ theorem pairAlg_extSnd MonoidAlgebra.single ((1, τ) : Equiv.Perm (Fin n) × Equiv.Perm (Fin n)) (1 : ℂ) := by - show MonoidAlgebra.mapDomain _ (MonoidAlgebra.single τ 1) = _ + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single τ 1) = _ exact MonoidAlgebra.mapDomain_single rw [hs, pairAlg_single, permAlg_single, permMor_one, MonoidalCategory.id_tensorHom] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorZigzag.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorZigzag.lean index 69200d44bc..611e6f3aa0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorZigzag.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorZigzag.lean @@ -54,7 +54,7 @@ theorem tensorCopair_point (λ_ (𝟙_ D)).inv ≫ (η[A] ⊗ₘ η[A]) ≫ modTensorπ A (regularMod A) (regularMod A) := by rw [regPairUnfold] - show η[A] ≫ (λ_ A).inv ≫ η[A] ▷ A ≫ + change η[A] ≫ (λ_ A).inv ≫ η[A] ▷ A ≫ modTensorπ A (regularMod A) (regularMod A) = _ rw [leftUnitor_inv_naturality_assoc, whisker_exchange_assoc, MonoidalCategory.tensorHom_def, @@ -162,6 +162,282 @@ theorem tensorHom_actRight_π 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. -/ @@ -220,54 +496,13 @@ theorem interchange_zigContract (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₂')) _, + ((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 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 + 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₂), @@ -365,7 +600,7 @@ theorem interchange_zigContract (modTensorπ A N₂' N₂ ≫ d₂.pair)) ≫ μ[A])) ≫ (β_ (N₁.X ⊗ N₂.X) A).hom ≫ (A ◁ modTensorπ A N₁ N₂) ≫ modTensorAct A N₁ N₂ := by - show (modTensorπ A N₁ N₂ ⊗ₘ + 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])) ≫ @@ -383,85 +618,7 @@ theorem interchange_zigContract 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 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₂) + have hR := zigContract_tensor_components_raw A d₁ d₂ refine Eq.trans ?_ hR.symm conv_lhs => rw [MonoidalCategory.whiskerLeft_comp, MonoidalCategory.whiskerLeft_comp] @@ -544,8 +701,10 @@ theorem interchange_zagContract (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₂')), + ((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₂' ⊗ @@ -565,50 +724,7 @@ theorem interchange_zagContract ← 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 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 + 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₂'))] @@ -696,7 +812,7 @@ theorem interchange_zagContract (N₁'.X ⊗ N₂'.X)) ≫ (A ◁ modTensorπ A N₁' N₂') ≫ modTensorAct A N₁' N₂' := by - show ((tensorμ N₁'.X N₂'.X N₁.X N₂.X ≫ + 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₂') ≫ @@ -708,86 +824,7 @@ theorem interchange_zagContract ((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 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₂') + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TrichotomyClose.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TrichotomyClose.lean index 53ed892ec9..53fc62f65a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TrichotomyClose.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TrichotomyClose.lean @@ -130,8 +130,8 @@ theorem devissageTrichotomy_of_descent IsZero (modPow B R.X (k + 2)) → IsZero R.X) : DevissageTrichotomy D L X := by intro st - letI := st.monObj - letI := st.comm + let := st.monObj + let := st.comm by_cases hS : ∀ n : ℕ, ¬ IsZero (symPow st.base st.rest.X n) · exact Or.inl hS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistBiprod.lean index c2dc2b4195..653b4c8287 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistBiprod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistBiprod.lean @@ -162,7 +162,7 @@ theorem twistBiprodActL_fst (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 - letI := modBiprodModObj A P Q + let := modBiprodModObj A P Q exact actAcross_whiskerLeft_of A V biprod.fst (modBiprodAct_fst A P Q) @@ -175,7 +175,7 @@ theorem twistBiprodActL_snd (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 - letI := modBiprodModObj A P Q + let := modBiprodModObj A P Q exact actAcross_whiskerLeft_of A V biprod.snd (modBiprodAct_snd A P Q) @@ -227,7 +227,7 @@ theorem twistBiprodActR_inv twistBiprodActR A V P Q ≫ tensorLeftBiprodInv V P.X Q.X = (A ◁ tensorLeftBiprodInv V P.X Q.X) ≫ twistBiprodActL A V P Q := by - haveI : IsIso (tensorLeftBiprodHom V P.X Q.X) := + 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⟩ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistFreeTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistFreeTensor.lean index e140fcca7f..883e6f4871 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistFreeTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistFreeTensor.lean @@ -42,8 +42,8 @@ theorem freeRegTwist_act letI := ModObj.regular A ((α_ A A V).inv ≫ (μ[A] ▷ V)) ≫ (β_ A V).hom = (A ◁ (β_ A V).hom) ≫ actAcross A V A := by - letI := ModObj.regular A - show ((α_ A A V).inv ≫ (μ[A] ▷ V)) ≫ (β_ A V).hom = + 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, @@ -60,13 +60,13 @@ noncomputable def freeRegTwistIso (V : D) : freeMod A V ≅ tensorLeftMod A V (regularMod A) where hom := Mod.Hom.mk' (β_ A V).hom (by - letI := ModObj.regular A - show ((α_ A A V).inv ≫ (μ[A] ▷ V)) ≫ (β_ A V).hom = + 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 - letI := ModObj.regular A - show actAcross A V A ≫ (β_ A V).inv = + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistShuffle.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistShuffle.lean index 0569898b2d..588283aafd 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistShuffle.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistShuffle.lean @@ -94,7 +94,7 @@ theorem twistShuffleCover_cond Category.assoc, h] simp only [Category.assoc] rw [actAcross, actAcross] - show ((β_ (V ⊗ R.X) A).hom ≫ (α_ A V R.X).inv ≫ + 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) = @@ -338,7 +338,7 @@ theorem twistShuffleHom_twistShuffleInv (tensorLeftMod A W S) rw [modTensorπ_twistShuffleHom_assoc, Category.comp_id, twistShuffleCover] - show (tensorμ V R.X W S.X ≫ + 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) @@ -382,7 +382,7 @@ theorem twistShuffleHom_act twistShuffleHom A V W R S = (A ◁ twistShuffleHom A V W R S) ≫ actAcross A (V ⊗ W) (modTensor A R S) := by - letI := modTensorModObj A R S + 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] @@ -397,7 +397,7 @@ theorem twistShuffleHom_act ((V ⊗ W) ◁ modTensorAct A R S) from by rw [actAcross_eq_braidPast] rfl] - show (α_ A (V ⊗ R.X) (W ⊗ S.X)).inv ≫ + 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 ≫ @@ -468,8 +468,8 @@ theorem twistShuffleInv_act (A ◁ twistShuffleInv A V W R S) ≫ modTensorAct A (tensorLeftMod A V R) (tensorLeftMod A W S) := by - letI := modTensorModObj A R S - haveI : IsIso (twistShuffleHom A V W R S) := + 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⟩ @@ -519,7 +519,7 @@ noncomputable def tensorLeftModContextHom tensorLeftMod A V M ⟶ tensorLeftMod A V' M := Mod.Hom.mk' (f ▷ M.X) (by - show actAcross A V M.X ≫ (f ▷ M.X) = + 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) @@ -532,7 +532,7 @@ noncomputable def tensorLeftModWhiskerHom tensorLeftMod A V M ⟶ tensorLeftMod A V N := Mod.Hom.mk' (V ◁ g.hom) (by - show actAcross A V M.X ≫ (V ◁ g.hom) = + 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 @@ -551,11 +551,11 @@ noncomputable def tensorLeftModContextIso hom := tensorLeftModContextHom A e.hom M inv := tensorLeftModContextHom A e.inv M hom_inv_id := Mod.hom_ext _ _ (by - show (e.hom ▷ M.X) ≫ (e.inv ▷ M.X) = 𝟙 _ + 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 - show (e.inv ▷ M.X) ≫ (e.hom ▷ M.X) = 𝟙 _ + change (e.inv ▷ M.X) ≫ (e.hom ▷ M.X) = 𝟙 _ rw [← MonoidalCategory.comp_whiskerRight, Iso.inv_hom_id, MonoidalCategory.id_whiskerRight]) @@ -569,13 +569,13 @@ noncomputable def tensorLeftModWhiskerIso hom := tensorLeftModWhiskerHom A V f.hom inv := tensorLeftModWhiskerHom A V f.inv hom_inv_id := Mod.hom_ext _ _ (by - show (V ◁ f.hom.hom) ≫ (V ◁ f.inv.hom) = 𝟙 _ + 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 - show (V ◁ f.inv.hom) ≫ (V ◁ f.hom.hom) = 𝟙 _ + 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, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistUnitor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistUnitor.lean index c63c19ab25..ce5c1f4966 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistUnitor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistUnitor.lean @@ -64,11 +64,11 @@ noncomputable def tensorLeftUnitMod (M : Mod D A) : tensorLeftMod A (𝟙_ D) M ≅ M where hom := Mod.Hom.mk' (λ_ M.X).hom (by - show actAcross A (𝟙_ D) M.X ≫ (λ_ M.X).hom = + 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 - show actLeft A M.X ≫ (λ_ M.X).inv = + 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 @@ -105,13 +105,13 @@ noncomputable def tensorLeftAssocMod tensorLeftMod A V (tensorLeftMod A W M) ≅ tensorLeftMod A (V ⊗ W) M where hom := Mod.Hom.mk' (α_ V W M.X).inv (by - show actAcross A V (tensorLeftMod A W M).X ≫ + 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 - show actAcross A (V ⊗ W) M.X ≫ (α_ V W M.X).hom = + 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) @@ -147,13 +147,13 @@ theorem freeTwist_act (braidPast A V X).hom = (A ◁ (braidPast A V X).hom) ≫ actAcross A V (freeMod A X).X := by - letI := freeModObj A X + 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 - show ((α_ A A (V ⊗ X)).inv ≫ (μ[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), @@ -172,13 +172,13 @@ noncomputable def freeTwistIso (V X : D) : freeMod A (V ⊗ X) ≅ tensorLeftMod A V (freeMod A X) where hom := Mod.Hom.mk' (braidPast A V X).hom (by - show ((α_ A A (V ⊗ X)).inv ≫ (μ[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 (freeMod A X).X exact freeTwist_act A V X) inv := Mod.Hom.mk' (braidPast A V X).inv (by - show actAcross A V (freeMod A X).X ≫ + 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))) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitBase.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitBase.lean index 6f111f3c1f..1be91aed6d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitBase.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitBase.lean @@ -130,12 +130,12 @@ noncomputable def freeModUnitBase [Category.{v} D] [MonoidalCategory D] (V : D) : freeMod (𝟙_ D) V ≅ unitMod V where hom := Mod.Hom.mk' (λ_ V).hom (by - show ((α_ (𝟙_ D) (𝟙_ D) V).inv ≫ (λ_ (𝟙_ D)).hom ▷ V) ≫ + 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 - show (λ_ V).hom ≫ (λ_ V).inv = + change (λ_ V).hom ≫ (λ_ V).inv = (𝟙_ D) ◁ (λ_ V).inv ≫ ((α_ (𝟙_ D) (𝟙_ D) V).inv ≫ (λ_ (𝟙_ D)).hom ▷ V) exact freeModUnitBase_linear_inv V) @@ -163,13 +163,13 @@ noncomputable def modBiprodZeroLeft inv := modBiprodInr A Z N hom_inv_id := by apply Mod.Hom.ext - show (biprod.snd ≫ biprod.inr : Z.X ⊞ N.X ⟶ _) = 𝟙 _ + 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 - show (biprod.inr ≫ biprod.snd : N.X ⟶ _) = 𝟙 _ + change (biprod.inr ≫ biprod.snd : N.X ⟶ _) = 𝟙 _ rw [biprod.inr_snd] end BiprodZero diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitSimple.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitSimple.lean index 644b69d987..3572f5818b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitSimple.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitSimple.lean @@ -203,11 +203,11 @@ 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 - haveI := tensorLeft_preservesMono (A := A) (cokernel i) - haveI := tensorRight_preservesEpi (A := A) U - haveI : Mono (cokernel i ◁ i) := + 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 - haveI : Epi (cokernel.π i ▷ U) := + 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] @@ -220,11 +220,11 @@ 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 - haveI := tensorRight_preservesMono (A := A) (cokernel i) - haveI := tensorLeft_preservesEpi (A := A) U - haveI : Mono (i ▷ cokernel i) := + 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 - haveI : Epi (U ◁ cokernel.π 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] @@ -237,8 +237,8 @@ private theorem isZero_kernelMate_tensor [MonoidalPreadditive A] [RigidCategory A] {U : A} (i : U ⟶ 𝟙_ A) [Mono i] : IsZero (kernel (unitMate i) ⊗ U) := by - haveI := tensorRight_preservesMono (A := A) U - haveI : Mono (kernel.ι (unitMate i) ▷ U) := + 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 _)) @@ -291,7 +291,7 @@ private theorem isIso_whiskerLeft_kernelMate [MonoidalPreadditive A] [RigidCategory A] {U : A} (i : U ⟶ 𝟙_ A) [Mono i] : IsIso (cokernel i ◁ kernel.ι (unitMate i)) := by - haveI : PreservesLimitsOfSize.{0, 0} (tensorLeft (cokernel i)) := + have : PreservesLimitsOfSize.{0, 0} (tensorLeft (cokernel i)) := tensorLeft_preservesLimits (cokernel i) have hlim := isLimitForkMapOfIsLimit' (tensorLeft (cokernel i)) (kernel.condition (unitMate i)) (kernelIsKernel (unitMate i)) @@ -301,11 +301,11 @@ private theorem isIso_whiskerLeft_kernelMate (𝟙 ((tensorLeft (cokernel i)).obj (𝟙_ A))) (by rw [hzero, comp_zero]) simp only [Fork.ι_ofι] at hl - haveI : IsSplitEpi + have : IsSplitEpi ((tensorLeft (cokernel i)).map (kernel.ι (unitMate i))) := IsSplitEpi.mk' ⟨l, hl⟩ - haveI := tensorLeft_preservesMono (A := A) (cokernel i) - haveI : Mono ((tensorLeft (cokernel i)).map (kernel.ι (unitMate i))) := + 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))) @@ -329,13 +329,13 @@ private theorem isZero_of_sub_of_tensor_isZero {U T : A} (i : U ⟶ 𝟙_ A) [Mono i] (t : T ⟶ U) (ht : Mono t) (hT : IsZero (T ⊗ U)) : IsZero T := by - haveI := ht - haveI := tensorRight_preservesMono (A := A) (cokernel i) - haveI : Mono (t ▷ cokernel i) := + 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) - haveI : PreservesLimitsOfSize.{0, 0} (tensorLeft T) := + have : PreservesLimitsOfSize.{0, 0} (tensorLeft T) := tensorLeft_preservesLimits T have hbase : IsLimit (KernelFork.ofι i (cokernel.condition i)) := Abelian.monoIsKernelOfCokernel @@ -343,12 +343,12 @@ private theorem isZero_of_sub_of_tensor_isZero (cokernelIsCokernel i) have hlim := isLimitForkMapOfIsLimit' (tensorLeft T) (cokernel.condition i) hbase - haveI : Mono (T ◁ cokernel.π i) := + have : Mono (T ◁ cokernel.π i) := Preadditive.mono_of_isZero_kernel' _ hlim hT - haveI := tensorLeft_preservesEpi (A := A) T - haveI : Epi (T ◁ cokernel.π i) := + have := tensorLeft_preservesEpi (A := A) T + have : Epi (T ◁ cokernel.π i) := Functor.map_epi (tensorLeft T) (cokernel.π i) - haveI : IsIso (T ◁ cokernel.π i) := isIso_of_mono_of_epi _ + 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 @@ -365,16 +365,16 @@ 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] [MonoidalLinear ℂ A] + [MonoidalCategory A] [MonoidalPreadditive A] [RigidCategory A] (hu : HasScalarUnit A) : Simple (𝟙_ A) := by constructor intro U i hi - haveI := hi + have := hi constructor · -- an isomorphism into the unit is nonzero intro hIso h0 - haveI := hIso + 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 _) @@ -382,10 +382,10 @@ theorem simple_unit_of_hasScalarUnit intro hne -- `W ⟶ 𝟙 ⟶ V` is epi: it factors as -- `λ⁻¹ ≫ (π ▷ W ≫ V ◁ ι) ≫ ρ` with `V ◁ ι` invertible - haveI : IsIso (cokernel i ◁ kernel.ι (unitMate i)) := + have : IsIso (cokernel i ◁ kernel.ι (unitMate i)) := isIso_whiskerLeft_kernelMate i - haveI := tensorRight_preservesEpi (A := A) (kernel (unitMate i)) - haveI : Epi (cokernel.π i ▷ kernel (unitMate 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 @@ -395,7 +395,7 @@ theorem simple_unit_of_hasScalarUnit ≫ (ρ_ (cokernel i)).hom := by rw [← whisker_exchange] simp [unitors_inv_equal] - haveI : Epi (kernel.ι (unitMate i) ≫ cokernel.π i) := by + 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 @@ -408,9 +408,9 @@ theorem simple_unit_of_hasScalarUnit ≫ kernel.ι (unitMate i)) (by rw [Category.assoc]; exact kernel.condition _) simp only [Fork.ι_ofι] at hj - haveI : Mono (j ≫ i) := by rw [hj]; exact mono_comp _ _ - haveI := tensorRight_preservesMono (A := A) U - haveI : Mono + 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 @@ -420,9 +420,9 @@ theorem simple_unit_of_hasScalarUnit ((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 - haveI : Mono (kernel.ι (unitMate i) ≫ cokernel.π i) := + have : Mono (kernel.ι (unitMate i) ≫ cokernel.π i) := Abelian.mono_of_kernel_ι_eq_zero _ (hK.eq_zero_of_src _) - haveI : IsIso (kernel.ι (unitMate i) ≫ cokernel.π i) := + 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 := @@ -440,7 +440,7 @@ theorem simple_unit_of_hasScalarUnit rw [Category.assoc, hσq, Category.comp_id] rw [h0, zero_comp] at h2 exact h2.symm - haveI : Epi i := Abelian.epi_of_cokernel_π_eq_zero i hq0 + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UniversalAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UniversalAlgebra.lean index beb1e9f7c6..f6df02f104 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UniversalAlgebra.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UniversalAlgebra.lean @@ -51,11 +51,11 @@ theorem exists_universal_algebra classical choose pm qm Am Amon Acomm Ane Aiso using hmix choose Bs Bmon Bcomm Bne Bsec using hsplit - letI : ∀ i : J ⊕ K, MonObj (Sum.elim Am Bs i) := fun i => + 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 - letI : ∀ i : J ⊕ K, IsCommMonObj (Sum.elim Am Bs i) := fun i => + 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 @@ -67,13 +67,13 @@ theorem exists_universal_algebra refine ⟨𝔸, hmon, hcomm, hne, ?_, ?_⟩ · intro j obtain ⟨φ, hφ⟩ := hmap (Sum.inl j) - haveI : IsMonHom (show Am j ⟶ 𝔸 from φ) := hφ + 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) - haveI : IsMonHom (show Bs k ⟶ 𝔸 from φ) := hφ + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/WhiskerFaithful.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/WhiskerFaithful.lean index 7f7aeb3c4f..a3b917d125 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/WhiskerFaithful.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/WhiskerFaithful.lean @@ -57,7 +57,7 @@ theorem eq_zero_of_whiskerRight_eq_zero (hs : Simple (𝟙_ A)) {X : A} (hX : ¬ IsZero X) {P Q : A} {f : P ⟶ Q} (hw : f ▷ X = 0) : f = 0 := by - haveI := hs + have := hs set ev' : X ⊗ (Xᘁ) ⟶ 𝟙_ A := (β_ X (Xᘁ)).hom ≫ ε_ X (Xᘁ) with hev' have hne : ev' ≠ 0 := by @@ -65,10 +65,10 @@ theorem eq_zero_of_whiskerRight_eq_zero refine evaluation_ne_zero hX ?_ have := congrArg (fun g => (β_ X (Xᘁ)).inv ≫ g) hz simpa [hev'] using this - haveI : Epi ev' := epi_of_nonzero_to_simple hne - haveI : Epi (P ◁ ev') := by + have : Epi ev' := epi_of_nonzero_to_simple hne + have : Epi (P ◁ ev') := by have heq : (tensorLeft P).map ev' = P ◁ ev' := rfl - haveI : (tensorLeft P).PreservesEpimorphisms := + have : (tensorLeft P).PreservesEpimorphisms := Functor.preservesEpimorphisms_of_adjunction (tensorLeftAdjunction (ᘁP) P) rw [← heq] @@ -150,7 +150,7 @@ theorem isZero_left_of_tensor_isZero (β_ V (Vᘁ)).inv ≫ ((β_ V (Vᘁ)).hom ≫ ε_ V (Vᘁ)) from by rw [← Category.assoc, Iso.inv_hom_id, Category.id_comp], h0, Limits.comp_zero] - haveI := hs + 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ᘁ))) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/WordMap.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/WordMap.lean index e0d703c05b..fa1422dd9b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/WordMap.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/WordMap.lean @@ -113,7 +113,7 @@ theorem wordMap_natural | zero => intro w; exact Category.id_comp _ | succ n ih => intro w - show (wordCongrMap α β n (w ∘ Fin.castSucc) ⊗ₘ + 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))) = @@ -203,7 +203,7 @@ theorem wordMap_const_true | zero => exact (Category.id_comp _).symm | succ n ih => - show wordMap f g n (fun _ => true) ⊗ₘ f = _ + change wordMap f g n (fun _ => true) ⊗ₘ f = _ rw [ih] exact eqToHom_tensor_pull (wordPow_const_true U V n) _ _ @@ -283,7 +283,7 @@ theorem wordMap_standard wordMap_const_true f g, eqToHom_trans_assoc, eqToHom_trans_assoc] exact map_pow_cast f p _ - show ((ρ_ (tensorPow A U p)).hom ≫ + 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)) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagCarrier.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagCarrier.lean index c730554d7b..39b48844fd 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagCarrier.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagCarrier.lean @@ -68,7 +68,7 @@ theorem modMultiπ_single [MonObj A] (X : Mod D A) : modMultiπ A [X] ≫ (modMultiSingle A X).hom = (ρ_ X.X).hom := by - show (modMultiTriv A (modSlots_singleton A X)).inv ≫ + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagNonzero.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagNonzero.lean index ecb291db12..fad306aae6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagNonzero.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagNonzero.lean @@ -68,3 +68,5 @@ theorem unit_copair_ne_zero (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 index 2af7daf7ba..e8ba529b40 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagSandwich.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagSandwich.lean @@ -126,7 +126,7 @@ theorem sandwichIns_hom modTensorπ A (modTensorMod A M M') M := by have h := modTensorMap_of_regular A (modTensorMod A M M') M (d.copairMod) - show (modTensorUnitLeft A M).inv ≫ + change (modTensorUnitLeft A M).inv ≫ modTensorMap A (d.copairMod) (𝟙 M) = _ rw [← h, Iso.inv_hom_id_assoc] rfl @@ -144,7 +144,7 @@ theorem sandwich_zig_carrier (sandwichIns A d ≫ sandwichCon A d).hom = (λ_ M.X).inv ≫ ((η[A] ≫ d.copair) ▷ M.X) ≫ zigContract A d.pair d.pair_linear := by - show (sandwichIns A d).hom ≫ (sandwichCon A d).hom = _ + change (sandwichIns A d).hom ≫ (sandwichCon A d).hom = _ rw [sandwichIns_hom] refine Eq.trans (Category.assoc _ _ _) ?_ refine whisker_eq _ ?_ @@ -259,7 +259,7 @@ theorem sandwichInsR_hom modTensorπ A M' (modTensorMod A M M') := by have h := modTensorMap_of_regular_right A M' (modTensorMod A M M') (d.copairMod) - show (modTensorUnitRight A M').inv ≫ + change (modTensorUnitRight A M').inv ≫ modTensorMap A (𝟙 M') (d.copairMod) = _ rw [← h, Iso.inv_hom_id_assoc] rfl @@ -275,7 +275,7 @@ theorem sandwich_zag_carrier (sandwichInsR A d ≫ sandwichConR A d).hom = (ρ_ M'.X).inv ≫ (M'.X ◁ (η[A] ≫ d.copair)) ≫ zagContract A d.pair d.pair_linear := by - show (sandwichInsR A d).hom ≫ (sandwichConR A d).hom = _ + change (sandwichInsR A d).hom ≫ (sandwichConR A d).hom = _ rw [sandwichInsR_hom] refine Eq.trans (Category.assoc _ _ _) ?_ refine whisker_eq _ ?_ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransfer.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransfer.lean index 20ec3cacfa..327de1bb3e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransfer.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransfer.lean @@ -233,7 +233,7 @@ theorem map_zagContract actLeft A Q'.X = ((modTensorπ A P' P ≫ d₀.pair) ▷ P'.X) ≫ actLeft A P'.X ≫ r'.hom := by - haveI := r'.isModHom + have := r'.isModHom have hd1 : (modTensorπ A P' P ≫ d₀.pair) ⊗ₘ r'.hom = ((modTensorπ A P' P ≫ d₀.pair) ▷ P'.X) ≫ (A ◁ r'.hom) := diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneBridge.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneBridge.lean index 292ab9e975..2e425c6e3c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneBridge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneBridge.lean @@ -38,7 +38,7 @@ theorem braided_transported_supersymmetry SuperVect.Hom.comp (μ ω X X ≫ ω.map (ε_ X X) ≫ η ω) (SuperVect.koszulBraiding (ω.obj X) (ω.obj X)) = (μ ω X X ≫ ω.map (ε_ X X) ≫ η ω) := by - show (β_ (ω.obj X) (ω.obj X)).hom ≫ + change (β_ (ω.obj X) (ω.obj X)).hom ≫ (μ ω X X ≫ ω.map (ε_ X X) ≫ η ω) = _ rw [← Category.assoc, ← Functor.Braided.braided, Category.assoc, ← Functor.map_comp_assoc, hsym] @@ -62,7 +62,7 @@ theorem braided_std_model (SuperVect.tensorHom e e) = stdForm k ℓ ∧ SuperVect.Hom.comp (SuperVect.tensorHom e' e') (ε ω ≫ ω.map (η_ X X) ≫ δ ω X X) = stdCopair k ℓ := by - letI EP : ExactPairing (ω.obj X) (ω.obj X) := + let EP : ExactPairing (ω.obj X) (ω.obj X) := ExactPairing.map ω (X := X) (Y := X) exact exists_std_model (μ ω X X ≫ ω.map (ε_ X X) ≫ η ω) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/EulerianIndependence.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/EulerianIndependence.lean index daf3d7780e..e41cd34a5c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/EulerianIndependence.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/EulerianIndependence.lean @@ -42,7 +42,7 @@ theorem EdgeSubset.mixedValue_eq_summand F.mixedValue h = F.mixedSummand h o := by have hne : Nonempty ((κ' : F.TransitionSystem) × κ'.Orientation) := ⟨⟨κ, o⟩⟩ - rw [EdgeSubset.mixedValue, dif_pos hne] + rw [EdgeSubset.mixedValue, dite_eq_left hne] exact hInd F h _ o open Classical in @@ -72,7 +72,7 @@ theorem EdgeSubset.mixedValue_transport (hInd : EulerianIndependence) EdgeSubset.TransitionSystem.Orientation.transport e.symm o₂⟩⟩ rwa [EdgeSubset.transport_symm_transport] at hback rw [EdgeSubset.mixedValue, EdgeSubset.mixedValue, - dif_neg hne, dif_neg hne₂] + dite_eq_right hne, dite_eq_right hne₂] open Classical in /-- **Isomorphism invariance of the mixed partition function**: @@ -104,13 +104,13 @@ theorem mixedPartition_transport (hInd : EulerianIndependence) (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 [dif_pos hc, dif_pos (hclosed.mp hc)] + · 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 [dif_neg hc, dif_neg (fun hcc => hc (hclosed.mpr hcc))] + · rw [dite_eq_right hc, dite_eq_right (fun hcc => hc (hclosed.mpr hcc))] end RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/KoszulAction.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/KoszulAction.lean index 284b3916e6..f63588d897 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/KoszulAction.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/KoszulAction.lean @@ -96,10 +96,10 @@ theorem superPermAction_zero_imp_evenPermRep_zero (n : ℕ) letI := P.linear superPermAction f P n x = 0 → evenPermRep f P n x = 0 := by - letI := P.additive - letI := P.linear + let := P.additive + let := P.linear intro h - show (evenComponentLinear _).comp + change (evenComponentLinear _).comp (superPermAction f P n).toLinearMap x = 0 simp only [LinearMap.comp_apply, AlgHom.toLinearMap_apply, h, map_zero] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaPerm.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaPerm.lean index d6f1e196f7..fc3bc4d1b7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaPerm.lean @@ -87,8 +87,8 @@ 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 - letI := P.additive - letI := P.linear + 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. diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaTensorPower.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaTensorPower.lean index a77065ee94..cf99a48f84 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaTensorPower.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaTensorPower.lean @@ -89,12 +89,12 @@ theorem omegaPow_inv_hom : P.ω.obj (SkeinObj.mk n)) = 𝟙 (P.ω.obj (SkeinObj.mk n)) | 0 => by - letI := P.braided - show (η P.ω ≫ ε P.ω : P.ω.obj (SkeinObj.mk 0) ⟶ _) = 𝟙 _ + let := P.braided + change (η P.ω ≫ ε P.ω : P.ω.obj (SkeinObj.mk 0) ⟶ _) = 𝟙 _ exact Functor.Monoidal.η_ε P.ω | n + 1 => by - letI := P.braided - show (δ P.ω (SkeinObj.mk n) (SkeinObj.mk 1) ≫ + 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)) = 𝟙 _ @@ -115,12 +115,12 @@ theorem omegaPow_hom_inv : superPow (strandImage f P) n) = 𝟙 (superPow (strandImage f P) n) | 0 => by - letI := P.braided - show (ε P.ω ≫ η P.ω : SuperVect.tensorUnit ⟶ _) = 𝟙 _ + let := P.braided + change (ε P.ω ≫ η P.ω : SuperVect.tensorUnit ⟶ _) = 𝟙 _ exact Functor.Monoidal.ε_η P.ω | n + 1 => by - letI := P.braided - show ((omegaPowHom f P n ⊗ₘ 𝟙 (P.ω.obj (SkeinObj.mk 1))) ≫ + 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)))) = 𝟙 _ @@ -168,7 +168,7 @@ theorem isoConj_one {C : Type*} [Category C] {X Y : C} simp only [isoConj, id_comp, e.hom_inv_id] /-- And composition. -/ -theorem isoConj_mul {C : Type*} [Category C] [Preadditive C] +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 @@ -179,14 +179,14 @@ theorem isoConj_mul {C : Type*} [Category C] [Preadditive C] theorem isoConj_zero {C : Type*} [Category C] [Preadditive C] {X Y : C} (e : X ≅ Y) : isoConj e (0 : End Y) = 0 := by - show e.hom ≫ (0 : Y ⟶ Y) ≫ e.inv = 0 + 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 - show e.hom ≫ (f + g) ≫ e.inv = + 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 @@ -198,7 +198,7 @@ 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 - show e.hom ≫ (r • f) ≫ e.inv = r • (e.hom ≫ f ≫ e.inv) + 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] @@ -206,7 +206,7 @@ theorem isoConj_smul {C : Type*} [Category C] [Preadditive C] /-- Conjugation by an iso is injective. -/ theorem isoConj_injective {C : Type*} [Category C] - [Preadditive C] {X Y : 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 = @@ -263,8 +263,8 @@ theorem superPermAction_eq_zero_iff (n : ℕ) letI := P.linear superPermAction f P n x = 0 ↔ omegaSkeinRep f P n x = 0 := by - letI := P.additive - letI := P.linear + let := P.additive + let := P.linear exact isoConj_eq_zero_iff (omegaPow f P n) (omegaSkeinRep f P n x) @@ -280,9 +280,9 @@ theorem superPermAction_perm (n : ℕ) (MonoidAlgebra.of ℂ (Equiv.Perm (Fin n)) σ) = isoConj (omegaPow f P n) (P.ω.map (permClass f n σ)) := by - letI := P.additive - letI := P.linear - show isoConj (omegaPow f P n) + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorDischarge.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorDischarge.lean index 692342e8f3..0913a6ad04 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorDischarge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorDischarge.lean @@ -37,7 +37,7 @@ namespace RS open CategoryTheory MonoidalCategory Category MonoidAlgebra open Functor.LaxMonoidal Functor.OplaxMonoidal -open scoped Classical + /-! ## Transport identification @@ -68,9 +68,9 @@ private theorem transport_perm_eq {R : ℕ} (f : EdgeRankParameter R) (superPermAction f P n (MonoidAlgebra.of ℂ _ σ)) ≫ (omegaPowHom f P n ≫ stdFromOmega f P e' n) = modelPermMap σ := by - letI := P.additive - letI := P.linear - letI := P.braided + 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 @@ -175,10 +175,10 @@ private theorem evenSectorTrTransport_perm evenSectorTrTransport f P e e' n (evenPermRep f P n (MonoidAlgebra.of ℂ _ σ)) = cycleProd (fun _ => (k : ℂ)) σ := by - letI := P.additive - letI := P.linear - letI := P.braided - show (evenSectorTr k l n).comp (evenConjTransport f P e e' n) + 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 @@ -212,10 +212,10 @@ private theorem oddSectorTrTransport_perm (evenPermRep f P n (MonoidAlgebra.of ℂ _ σ)) = ((Equiv.Perm.sign σ : ℤ) : ℂ) * cycleProd (fun _ => ((2 * l : ℕ) : ℂ)) σ := by - letI := P.additive - letI := P.linear - letI := P.braided - show (oddSectorTr k l n hn).comp (evenConjTransport f P e e' n) + 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 @@ -251,9 +251,9 @@ at every side `s' ≥ s` with `1 ≤ s`, both sector dimensions `k` theorem squareSectorBound_of_detPos (H : SquareBinomialDetPos) : SquareSectorBound := by intro R f P k l s hs1 e e' he'e hee' hdead - letI := P.additive - letI := P.linear - letI := P.braided + let := P.additive + let := P.linear + let := P.braided constructor · -- **k < s** via the even sector -- Apply sector_bound_of_dead with: diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorIntertwine.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorIntertwine.lean index 5428a225dc..4bbd88a80d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorIntertwine.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorIntertwine.lean @@ -55,7 +55,7 @@ namespace RS open Finset MonoidAlgebra -open scoped Classical + /-! ## All-even colourings -/ @@ -139,11 +139,11 @@ private theorem coordOf_basis_allEven (k ℓ n : ℕ) (allEvenEmb k ℓ n f) = if f = g then 1 else 0 := by unfold coordOf - rw [dif_pos (allEvenEmb_isEven k ℓ n f)] + rw [dite_eq_left (allEvenEmb_isEven k ℓ n f)] rw [evenCoord_basis] by_cases h : f = g - · subst h; rw [if_pos rfl, if_pos rfl] - · rw [if_neg h, if_neg (fun hh => h + · 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 -/ @@ -191,6 +191,7 @@ noncomputable def evenSectorTr (k ℓ n : ℕ) : /-! ## 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, @@ -220,7 +221,7 @@ theorem evenSectorTr_perm (k ℓ n : ℕ) (σ : Equiv.Perm (Fin n)) : (superPow (stdSuperPair k ℓ) n)).evenMap) = cycleProd (fun _ => (k : ℂ)) σ := by -- Unfold evenSectorTr - show ∑ f : Fin n → Fin k, + change ∑ f : Fin n → Fin k, (colourPowerEquiv k ℓ n).evenEquiv (((modelPermMap σ : SuperVect.Hom _ _).evenMap) (evenBasis k ℓ n @@ -238,7 +239,7 @@ theorem evenSectorTr_perm (k ℓ n : ℕ) (σ : Equiv.Perm (Fin n)) : ⟨allEvenEmb k ℓ n f, allEvenEmb_isEven k ℓ n f⟩)) (allEvenEmb k ℓ n f) := fun f => by unfold coordOf - rw [dif_pos (allEvenEmb_isEven k ℓ n f)] + 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, @@ -328,7 +329,7 @@ private theorem wordSign_allOdd {n : ℕ} (w : List (Fin n)) induction w generalizing g with | nil => simp [wordSign] | cons i w ih => - show adjSign (allOddEmb k ℓ (n + 1) g) + 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⟩) = @@ -336,7 +337,7 @@ private theorem wordSign_allOdd {n : ℕ} (w : List (Fin n)) have hadj : adjSign (allOddEmb k ℓ (n + 1) g) ⟨i.val, by omega⟩ ⟨i.val + 1, by omega⟩ = -1 := by unfold adjSign allOddEmb - rw [if_pos ⟨by simp [Sum.isRight], by simp [Sum.isRight]⟩] + 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)) @@ -440,11 +441,11 @@ private theorem coordOf_basis_allOdd (k ℓ n : ℕ) (hn : Even n) (allOddEmb k ℓ n g₁) = if g₁ = g₂ then 1 else 0 := by unfold coordOf - rw [dif_pos (allOddEmb_isEven k ℓ n hn g₁)] + rw [dite_eq_left (allOddEmb_isEven k ℓ n hn g₁)] rw [evenCoord_basis] by_cases h : g₁ = g₂ - · subst h; rw [if_pos rfl, if_pos rfl] - · rw [if_neg h, if_neg (fun hh => h + · 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 @@ -458,7 +459,7 @@ theorem oddSectorTr_perm (k ℓ n : ℕ) (hn : Even n) ((Equiv.Perm.sign σ : ℤ) : ℂ) * cycleProd (fun _ => ((2 * ℓ : ℕ) : ℂ)) σ := by -- Unfold - show ∑ g : Fin n → Fin (2 * ℓ), + change ∑ g : Fin n → Fin (2 * ℓ), (colourPowerEquiv k ℓ n).evenEquiv (((modelPermMap σ : SuperVect.Hom _ _).evenMap) (evenBasis k ℓ n @@ -476,7 +477,7 @@ theorem oddSectorTr_perm (k ℓ n : ℕ) (hn : Even n) ⟨allOddEmb k ℓ n g, allOddEmb_isEven k ℓ n hn g⟩)) (allOddEmb k ℓ n g) := fun g => by unfold coordOf - rw [dif_pos (allOddEmb_isEven k ℓ n hn g)] + 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 * ℓ), diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/TotalDimension.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/TotalDimension.lean index 44c7f122f2..9c8630c91e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/TotalDimension.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/TotalDimension.lean @@ -46,7 +46,7 @@ private theorem stdOmegaIso_perm {R k ℓ : ℕ} (stdOmegaIso f P e n).hom ≫ P.ω.map (permClass f n σ) ≫ (stdOmegaIso f P e n).inv = modelPermMap σ := by - letI := P.braided + 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, @@ -62,9 +62,9 @@ theorem stdModel_pow_le_connectionRank {R k ℓ : ℕ} (k + 2 * ℓ) ^ (2 * n) ≤ connectionRank f.val (2 * n) * (n + 1) ^ (2 * (k + 2 * ℓ) ^ 2) := by classical - letI := P.additive - letI := P.linear - letI := P.braided + 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BranchTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BranchTrace.lean index b4357b2745..61f09121fa 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BranchTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BranchTrace.lean @@ -63,9 +63,9 @@ theorem trace_symCast_charIdempotent (lam mu : YoungDiagram) (MonoidAlgebra.of ℂ (Equiv.Perm (Fin lam.card)) σ) = MonoidAlgebra.of ℂ (Equiv.Perm (Fin mu.card)) (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ) from by - show symCast h (MonoidAlgebra.of ℂ _ σ) = _ + change symCast h (MonoidAlgebra.of ℂ _ σ) = _ rw [symCast, MonoidAlgebra.of_apply, MonoidAlgebra.of_apply] - show MonoidAlgebra.mapDomain + change MonoidAlgebra.mapDomain (⇑(Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h))) (MonoidAlgebra.single σ (1 : ℂ)) = _ rw [MonoidAlgebra.mapDomain_single]] @@ -76,7 +76,7 @@ theorem trace_symCast_charIdempotent (lam mu : YoungDiagram) (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ)) = rhoS (jtSimple mu) (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ) from by - show (rhoS (jtSimple mu)).asAlgebraHom + change (rhoS (jtSimple mu)).asAlgebraHom (MonoidAlgebra.of ℂ _ _) = _ rw [MonoidAlgebra.of_apply, Representation.asAlgebraHom_single, one_smul]] @@ -126,11 +126,11 @@ theorem branching_of_pairing (lam mu : YoungDiagram) have htr := trace_symCast_charIdempotent lam mu h rw [← hy, hψ, map_zero] at htr have hd : ((nDim (jtSimple lam) : ℂ)) ≠ 0 := by - haveI := jtSimple_simple lam - haveI := IsSimpleModule.nontrivial + have := jtSimple_simple lam + have := IsSimpleModule.nontrivial (MonoidAlgebra ℂ (Equiv.Perm (Fin lam.card))) (jtSimple lam) - haveI : Nontrivial (subCarrier (jtSimple lam)) := + have : Nontrivial (subCarrier (jtSimple lam)) := inferInstanceAs (Nontrivial (jtSimple lam)) have := Module.finrank_pos (R := ℂ) (M := subCarrier (jtSimple lam)) diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CentralElem.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CentralElem.lean index b2edc7a2c9..9cc4c2dfbc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CentralElem.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CentralElem.lean @@ -28,7 +28,7 @@ noncomputable def classElem [Group G] [Fintype G] /-- The element built from a coefficient function has exactly those coefficients. -/ -theorem classElem_coeff [Group G] [Fintype G] [DecidableEq G] +theorem classElem_coeff [Group G] [Fintype G] (c : G → ℂ) (k : G) : (classElem c).coeff k = c k := by classical @@ -42,33 +42,34 @@ theorem classElem_coeff [Group G] [Fintype G] [DecidableEq G] 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.smul_apply (c g) _ k] + 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 [if_pos (Finset.mem_univ k)] + rw [ite_eq_left (Finset.mem_univ k)] /-- **Class functions give central elements.** -/ -theorem classElem_mul_comm [Group G] [Fintype G] [DecidableEq G] +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 - show (classElem c * MonoidAlgebra.of ℂ G m).coeff 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.mul_single_apply (classElem c) 1 m k, + 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.single_mul_apply (classElem c) 1 m k] + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharClass.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharClass.lean index e7fe97f387..05f28846a5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharClass.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharClass.lean @@ -90,7 +90,7 @@ theorem jtChar_inv (μ : YoungDiagram) refine Finset.sum_congr rfl fun σ _ => ?_ congr 1 by_cases hp : ∀ i, 0 ≤ jtSigned μ σ i - · rw [if_pos hp, if_pos hp, colourChar_inv] - · rw [if_neg hp, if_neg hp] + · 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 index 6b4740d876..65d5fc67da 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharDecomp.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharDecomp.lean @@ -66,7 +66,7 @@ private theorem rhoSub_val_eq rw [Representation.asAlgebraHom_single, one_smul] at h exact h rw [h1] - show (MonoidAlgebra.single g (1 : ℂ)) • (m : ρ.asModule) = ρ g (m : + change (MonoidAlgebra.single g (1 : ℂ)) • (m : ρ.asModule) = ρ g (m : ρ.asModule) rw [Representation.single_smul, one_smul]; rfl @@ -79,17 +79,19 @@ private theorem character_zero_of_finrank_zero {G : Type*} [Group G] (ρ : 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 - show (trace ℂ V) (ρ g) = 0 + 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] [Fintype G] : +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 => @@ -102,21 +104,21 @@ private theorem character_eq_sum_nChar_aux {G : Type*} [Group G] [Fintype G] : · 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 - haveI hnt : Nontrivial V := Module.nontrivial_of_finrank_pos hfpos - haveI : Nontrivial ρ.asModule := hnt - haveI : NeZero ((Nat.card G : ℂ)) := ⟨by + 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⟩ - haveI : IsSemisimpleRing (MonoidAlgebra ℂ G) := inferInstance - haveI : IsSemisimpleModule (MonoidAlgebra ℂ G) ρ.asModule := + 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 - haveI : Nontrivial (↥T) := IsSimpleModule.nontrivial (MonoidAlgebra ℂ G) T + have : Nontrivial (↥T) := IsSimpleModule.nontrivial (MonoidAlgebra ℂ G) T have hTpos : 0 < Module.finrank ℂ ↥(T.restrictScalars ℂ) := by - haveI : Nontrivial ↥(T.restrictScalars ℂ) := inferInstanceAs + have : Nontrivial ↥(T.restrictScalars ℂ) := inferInstanceAs (Nontrivial ↥T) exact Module.finrank_pos have hTW_C : IsCompl (T.restrictScalars ℂ : Submodule ℂ ρ.asModule) @@ -141,13 +143,13 @@ private theorem character_eq_sum_nChar_aux {G : Type*} [Group G] [Fintype G] : refine Representation.Equiv.mk (eTS.symm.restrictScalars ℂ) (fun g => ?_) apply LinearMap.ext; intro ⟨v, hv⟩ - simp only [comp_apply, LinearEquiv.coe_toLinearMap] + 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 - show (rhoSub ρ T) g ⟨v, hv⟩ = _ + 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 @@ -176,7 +178,7 @@ private theorem character_eq_sum_nChar_aux {G : Type*} [Group G] [Fintype G] : · 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 - show (trace ℂ V) (ρ g) = (trace ℂ _) (ρT g) + (trace ℂ _) (ρW g) + 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 @@ -208,13 +210,16 @@ private theorem character_eq_sum_nChar_aux {G : Type*} [Group G] [Fintype G] : /-- **Every character decomposes** into native characters of simple submodules of the regular module. -/ -theorem character_eq_sum_nChar {G : Type*} [Group G] [Fintype G] +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 := - character_eq_sum_nChar_aux (Module.finrank ℂ V) ρ le_rfl + ∀ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharEquiv.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharEquiv.lean index 73d22d51a1..d52530201f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharEquiv.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharEquiv.lean @@ -25,7 +25,6 @@ variable {G : Type*} theorem character_of_equiv [Group G] {V W : Type*} [AddCommGroup V] [Module ℂ V] [AddCommGroup W] [Module ℂ W] - [FiniteDimensional ℂ V] [FiniteDimensional ℂ W] {ρ : Representation ℂ G V} {σ : Representation ℂ G W} (e : ρ.Equiv σ) (g : G) : ρ.character g = σ.character g := @@ -33,10 +32,12 @@ theorem character_of_equiv [Group G] /-- Equivalent native representations have the same native character. -/ -theorem nChar_of_equiv [Group G] [Fintype G] +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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourWeight.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourWeight.lean index a62565a567..8cad2d9cf4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourWeight.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourWeight.lean @@ -36,9 +36,9 @@ theorem compContent_count (α : Fin N → ℕ) (j : Fin N) : rw [compContent, Multiset.count_sum'] rw [Finset.sum_eq_single j (fun b _ hb => by - rw [Multiset.count_replicate, if_neg hb]) + rw [Multiset.count_replicate, ite_eq_right hb]) (fun h => absurd (Finset.mem_univ j) h)] - rw [Multiset.count_replicate, if_pos rfl] + rw [Multiset.count_replicate, ite_eq_left rfl] /-- Its size is the composition's total. -/ theorem compContent_card (α : Fin N → ℕ) : @@ -132,14 +132,14 @@ theorem sum_colourChar_weight (α : Fin N → ℕ) else 0) := by refine Finset.sum_congr rfl fun g _ => ?_ by_cases hg : ∀ j, fibreCard g j = α j - · rw [if_pos hg, Finset.sum_filter] + · rw [ite_eq_left hg, Finset.sum_filter] exact Finset.sum_congr rfl fun π _ => by by_cases hf : g ∘ π = g - · rw [if_pos ⟨hg, hf⟩, if_pos hf] - · rw [if_neg (fun hc => hf hc.2), if_neg hf] - · rw [if_neg hg] + · 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 π _ => - if_neg (fun hc => hg hc.1)] + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CommutantBound.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CommutantBound.lean index d538a1b969..a7b918ec55 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CommutantBound.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CommutantBound.lean @@ -20,7 +20,7 @@ summands, counted with multiplicity. namespace RS open Finset LinearMap Representation -open scoped Classical + noncomputable section @@ -41,7 +41,7 @@ private noncomputable instance cardComplexInvertible exact_mod_cast Fintype.card_ne_zero) private theorem intertwining_finrank_sum_right - [Group G] [Fintype G] + [Group G] [Finite G] [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] [AddCommGroup W] [Module ℂ W] [FiniteDimensional ℂ W] (ρ : Representation ℂ G V) (τ : Representation ℂ G W) @@ -51,6 +51,8 @@ private theorem intertwining_finrank_sum_right (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] @@ -59,7 +61,7 @@ private theorem intertwining_finrank_sum_right rw [Finset.sum_comm, Finset.mul_sum] private theorem intertwining_finrank_sum_left - [Group G] [Fintype G] + [Group G] [Finite G] [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] [AddCommGroup W] [Module ℂ W] [FiniteDimensional ℂ W] (ρ : Representation ℂ G V) (τ : Representation ℂ G W) @@ -69,6 +71,8 @@ private theorem intertwining_finrank_sum_left (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] @@ -77,7 +81,7 @@ private theorem intertwining_finrank_sum_left rw [Finset.sum_comm] private theorem constituent_multiplicity_pos - [Group G] [Fintype G] + [Group G] [Finite G] [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] (ρ : Representation ℂ G V) {m : ℕ} (S : Fin m → Submodule (MonoidAlgebra ℂ G) @@ -86,8 +90,10 @@ private theorem constituent_multiplicity_pos (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] - haveI := rhoS_isIrreducible (S i) (hS i) + 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 @@ -114,6 +120,7 @@ private theorem trace_nProjector 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 @@ -140,7 +147,7 @@ theorem nDim_sq_le_finrank_of_projector_ne_zero the square root of the dimension of a factoring algebra, times the dimension of its commutant. -/ theorem finrank_le_sqrt_mul_commutant - [Group G] [Fintype G] + [Group G] [Finite G] [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] (ρ : Representation ℂ G V) {A : Type*} [Ring A] [Algebra ℂ A] [FiniteDimensional ℂ A] @@ -150,6 +157,7 @@ theorem finrank_le_sqrt_mul_commutant 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 @@ -162,7 +170,7 @@ theorem finrank_le_sqrt_mul_commutant intro hzero have ht := congrArg (LinearMap.trace ℂ V) (hker _ hzero) rw [trace_nProjector, map_zero] at ht - haveI : Nontrivial (subCarrier (S i)) := + 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' @@ -190,7 +198,7 @@ theorem finrank_le_sqrt_mul_commutant dimension at most `B ^ 2`, its dimension is at most `B` times the dimension of its commutant. -/ theorem finrank_le_mul_commutant - [Group G] [Fintype G] + [Group G] [Finite G] [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] (ρ : Representation ℂ G V) {A : Type*} [Ring A] [Algebra ℂ A] [FiniteDimensional ℂ A] @@ -199,6 +207,8 @@ theorem finrank_le_mul_commutant (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 @@ -209,7 +219,7 @@ theorem finrank_le_mul_commutant factoring algebra dimension times the square of the commutant dimension. -/ theorem finrank_sq_le_mul_commutant_sq - [Group G] [Fintype G] + [Group G] [Finite G] [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] (ρ : Representation ℂ G V) {A : Type*} [Ring A] [Algebra ℂ A] [FiniteDimensional ℂ A] @@ -217,6 +227,8 @@ theorem finrank_sq_le_mul_commutant_sq (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 ≤ diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ContentCount.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ContentCount.lean index 0963328c17..b7e29d6ffb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ContentCount.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ContentCount.lean @@ -27,7 +27,7 @@ variable {n N : ℕ} /-- 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 - show (Finset.univ.val.map (x ∘ f)).prod = ((Finset.univ.val.map f).map x).prod + 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. -/ @@ -47,7 +47,7 @@ private theorem perm_map_univ_val (σ : Equiv.Perm (Fin n)) : theorem content_comp_perm (f : Fin n → Fin N) (σ : Equiv.Perm (Fin n)) : content (f ∘ σ) = content f := by unfold content; refine Subtype.ext ?_ - show Finset.univ.val.map (f ∘ ⇑σ) = Finset.univ.val.map f + 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] @@ -75,7 +75,7 @@ theorem content_eq_exists_perm (f g : Fin n → Fin N) 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 => ?_⟩ - show f ((Tuple.sort f) ((Tuple.sort g)⁻¹ i)) = g 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 @@ -220,7 +220,7 @@ theorem sum_fibreFactorial_weight' {n N : ℕ} (x : Fin N → ℂ) ((∏ j : Fin N, (s.1.count j).factorial : ℕ) : ℂ) * (s.1.map x).prod := by rintro ⟨f, hf⟩ - show ((∏ j : Fin N, (fibreCard f j).factorial : ℕ) : ℂ) * + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FixWeight.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FixWeight.lean index 13d0df418b..476377da6a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FixWeight.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FixWeight.lean @@ -162,3 +162,5 @@ theorem colour_cycleSum (H1 : PermCongrCT) (H2 : SigmaCT) 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 index 228fd1d513..9653c1948c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/HVal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/HVal.lean @@ -68,7 +68,7 @@ theorem sum_split_eq_count (x : Fin N → ℂ) (k : ℕ) (j : Fin N) : (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 _ => ?_ - show (S.1.count j : ℂ) * (S.1.map x).prod = + 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' @@ -89,8 +89,8 @@ theorem sum_split_eq_count (x : Fin N → ℂ) (k : ℕ) (j : Fin N) : intro p hp refine Finset.mem_sigma.mpr ⟨Finset.mem_univ _, ?_⟩ refine Finset.mem_range.mpr ?_ - show p.1 < Multiset.count j (p.2.1 + Multiset.replicate (p.1 + 1) j) - rw [Multiset.count_add, Multiset.count_replicate, if_pos rfl] + 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 @@ -100,13 +100,13 @@ theorem sum_split_eq_count (x : Fin N → ℂ) (k : ℕ) (j : Fin N) : 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 - show q.2 < k + 1 + change q.2 < k + 1 omega · -- left inverse intro p hp refine Sigma.ext rfl (heq_of_eq ?_) refine Subtype.ext ?_ - show (p.2.1 + Multiset.replicate (p.1 + 1) j) - + 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 @@ -117,12 +117,12 @@ theorem sum_split_eq_count (x : Fin N → ℂ) (k : ℕ) (j : Fin N) : 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 - show (q.1.1 - Multiset.replicate (q.2 + 1) j) + + 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 - show x j ^ (p.1 + 1) * (p.2.1.map x).prod = + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTChar.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTChar.lean index cb57ba8f2b..91a3133f2c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTChar.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTChar.lean @@ -104,12 +104,12 @@ theorem jtChar_frobenius (H1 : PermCongrCT) (H2 : SigmaCT) rw [Finset.sum_comm] refine Finset.sum_congr rfl fun σ _ => ?_ by_cases hp : ∀ i, 0 ≤ jtSigned μ σ i - · rw [if_pos hp, Finset.mul_sum] + · rw [ite_eq_left hp, Finset.mul_sum] refine Finset.sum_congr rfl fun π _ => ?_ - rw [if_pos hp, mul_assoc] - · rw [if_neg hp] + rw [ite_eq_left hp, mul_assoc] + · rw [ite_eq_right hp] rw [Finset.sum_eq_zero fun π _ => by - rw [if_neg hp, mul_zero, zero_mul]] + rw [ite_eq_right hp, mul_zero, zero_mul]] rw [mul_zero] have hterm : ∀ σ : Equiv.Perm (Fin μ.rowLens.length), ((Equiv.Perm.sign σ : ℤ) : ℂ) * @@ -122,7 +122,7 @@ theorem jtChar_frobenius (H1 : PermCongrCT) (H2 : SigmaCT) ∏ i, newtonHZ t (jtSigned μ σ i)) := by intro σ by_cases hp : ∀ i, 0 ≤ jtSigned μ σ i - · rw [if_pos hp] + · 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 @@ -131,7 +131,7 @@ theorem jtChar_frobenius (H1 : PermCongrCT) (H2 : SigmaCT) conv_lhs => rw [← Int.toNat_of_nonneg (hp i)] rw [newtonHZ_natCast]] ring - · rw [if_neg hp] + · rw [ite_eq_right hp] rw [not_forall] at hp obtain ⟨i0, hi0⟩ := hp rw [Finset.prod_eq_zero (Finset.mem_univ i0) diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIntChar.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIntChar.lean index fa78df6e2d..91b6f173f7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIntChar.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIntChar.lean @@ -53,7 +53,7 @@ theorem jtChar_eq_sum_sign_nChar (μ : YoungDiagram) : character_eq_sum_nChar (G := Equiv.Perm (Fin μ.card)) (colourRep (jtComp μ σ)) refine ⟨m, S, hSimp, fun π => ?_⟩ - rw [if_pos hp] + rw [ite_eq_left hp] -- colourRep_character converts representation character to colourChar have hconv : (colourChar (jtComp μ σ) π : ℂ) = ∑ i : Fin m, nChar (S i) π := by @@ -62,7 +62,7 @@ theorem jtChar_eq_sum_sign_nChar (μ : YoungDiagram) : rw [hconv, Finset.mul_sum] · -- Guard false: empty family, both sides are zero exact ⟨0, Fin.elim0, fun i => i.elim0, fun π => by - rw [if_neg hp, mul_zero]; simp⟩ + 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 @@ -91,14 +91,14 @@ theorem jtChar_eq_sum_sign_nChar (μ : YoungDiagram) : exact hdS_simp σ i · -- Sign values: (Perm.sign σ : ℤ) ∈ {1, -1} intro ⟨σ, _⟩ - show (Equiv.Perm.sign σ : ℤ) = 1 ∨ (Equiv.Perm.sign σ : ℤ) = -1 + 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 - show jtChar μ π = ∑ j : J, ((ε j : ℤ) : ℂ) * nChar (T j) π + 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), diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIrreducible.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIrreducible.lean index 4a9f7b57f0..e249b021cf 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIrreducible.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIrreducible.lean @@ -86,9 +86,9 @@ theorem jt_pm_nChar (μ : YoungDiagram) {J : Type} [Fintype J] (if Nonempty ((rhoS (T j')).Equiv (rhoS (T j))) then (1 : ℂ) else 0) := by intro j j' - haveI := rhoS_isIrreducible (T j) (hT j) - haveI := rhoS_isIrreducible (T j') (hT j') - haveI : Invertible ((Nat.card (Equiv.Perm (Fin μ.card)) : ℂ)) := + 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) @@ -99,7 +99,7 @@ theorem jt_pm_nChar (μ : YoungDiagram) {J : Type} [Fintype J] rw [Nat.card_eq_fintype_card, Fintype.card_perm, Fintype.card_fin]] at horth exact horth - letI sd : Setoid J := + let sd : Setoid J := ⟨fun j j' => Nonempty ((rhoS (T j)).Equiv (rhoS (T j'))), fun _ => ⟨Representation.Equiv.refl _⟩, fun ⟨e⟩ => ⟨e.symm⟩, @@ -143,8 +143,8 @@ theorem jt_pm_nChar (μ : YoungDiagram) {J : Type} [Fintype J] (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 [if_pos hc, if_pos ((hgr j j').mpr ⟨hc.some.symm⟩)] - · rw [if_neg hc, if_neg (fun hgj => hc + · 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] @@ -167,8 +167,8 @@ theorem jt_pm_nChar (μ : YoungDiagram) {J : Type} [Fintype J] then ((ε j : ℤ) : ℂ) * ((ε j' : ℤ) : ℂ) else 0) from by by_cases hc : g j = g j' - · rw [if_pos hc, if_pos hc.symm, mul_one] - · rw [if_neg hc, if_neg (fun h => hc h.symm), mul_zero])] + · 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) : ℤ) : ℂ))] diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTOrtho.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTOrtho.lean index b764aa6c45..20d0aa77be 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTOrtho.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTOrtho.lean @@ -67,14 +67,14 @@ theorem jtChar_orthonormal (μ : YoungDiagram) : refine Finset.sum_congr rfl fun τ _ => ?_ by_cases hσ : ∀ i, 0 ≤ jtSigned μ σ i · by_cases hτ : ∀ i, 0 ≤ jtSigned μ τ i - · rw [if_pos ⟨hσ, hτ⟩, Finset.mul_sum] + · rw [ite_eq_left ⟨hσ, hτ⟩, Finset.mul_sum] refine Finset.sum_congr rfl fun π _ => ?_ - rw [if_pos hσ, if_pos hτ]; ring - · rw [if_neg (fun hc => hτ hc.2)] + 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 [if_neg hτ, mul_zero, mul_zero]] + rw [ite_eq_right hτ, mul_zero, mul_zero]] rw [mul_zero] - · rw [if_neg (fun hc => hσ hc.1)] + · rw [ite_eq_right (fun hc => hσ hc.1)] rw [show (∑ π : Equiv.Perm (Fin n), ((Equiv.Perm.sign σ : ℤ) : ℂ) * (if ∀ i, 0 ≤ jtSigned μ σ i @@ -83,7 +83,7 @@ theorem jtChar_orthonormal (μ : YoungDiagram) : (if ∀ i, 0 ≤ jtSigned μ τ i then (colourChar (jtComp μ τ) π : ℂ) else 0))) = 0 from Finset.sum_eq_zero fun π _ => by - rw [if_neg hσ, mul_zero, zero_mul]] + 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 @@ -144,11 +144,11 @@ theorem jtChar_orthonormal (μ : YoungDiagram) : else 0)) := by intro σ τ by_cases hboth : (∀ i, 0 ≤ jtSigned μ σ i) ∧ (∀ i, 0 ≤ jtSigned μ τ i) - · rw [if_pos hboth, if_pos hboth] + · 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 [if_neg hboth, if_neg hboth, mul_zero, mul_zero] + · 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)) (_ : τ ∈ diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean index 4868e19f22..cb4e7d5c6b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean @@ -120,7 +120,7 @@ noncomputable def restrictHead (μ : YoungDiagram) {k : ℕ} invFun j := ⟨(σ⁻¹ (Fin.castLE hk j) : ℕ), head_maps_head μ hk σ⁻¹ (fun i hi => by have h1 := hfix i hi - show σ.symm i = i + change σ.symm i = i rw [Equiv.symm_apply_eq] exact h1.symm) j⟩ left_inv j := by @@ -226,7 +226,7 @@ theorem colourChar_extend_zero {n N k : ℕ} (hNk : N ≤ k) π := by classical let β : Fin k → ℕ := fun i => if h : (i : ℕ) < N then α ⟨i, h⟩ else 0 - show colourChar α π = colourChar β π + change colourChar α π = colourChar β π unfold colourChar -- Helper: extended fibre condition forces range into first N have range_bound : ∀ g : Fin n → Fin k, @@ -234,7 +234,7 @@ theorem colourChar_extend_zero {n N k : ℕ} (hNk : N ≤ k) intro g hfib x exact range_lt_of_fibreCard_zero g (fun j hj => by have := hfib j - simp only [β, dif_neg (by omega : ¬ (j : ℕ) < N)] at this + 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), @@ -256,7 +256,7 @@ theorem colourChar_extend_zero {n N k : ℕ} (hNk : N ≤ k) constructor · intro h have := congrArg Fin.val h - simp [Fin.val_castLE] at this + simp? [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 @@ -285,18 +285,18 @@ theorem colourChar_extend_zero {n N k : ℕ} (hNk : N ≤ k) simp only [Finset.mem_filter, Finset.mem_univ, true_and] constructor · intro j - show fibreCard (fun x => (⟨(g x : ℕ), hb x⟩ : Fin N)) j = α 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 - show (if h : (Fin.castLE hNk j : ℕ) < N then α ⟨(Fin.castLE hNk j : ℕ), + 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 [dif_pos hlt, show (⟨(Fin.castLE hNk j : ℕ), hlt⟩ : Fin N) = j from + 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) - · show (fun x => (⟨(g x : ℕ), hb x⟩ : Fin N)) ∘ ↑π = fun x => ⟨(g x : ℕ), hb + · change (fun x => (⟨(g x : ℕ), hb x⟩ : Fin N)) ∘ ↑π = fun x => ⟨(g x : ℕ), hb x⟩ ext x simp only [Function.comp] @@ -317,17 +317,17 @@ theorem colourChar_extend_zero {n N k : ℕ} (hNk : N ≤ k) simp only [Finset.mem_filter, Finset.mem_univ, true_and] constructor · intro j - show fibreCard (Fin.castLE hNk ∘ g) j = + change fibreCard (Fin.castLE hNk ∘ g) j = (if h : (j : ℕ) < N then α ⟨(j : ℕ), h⟩ else 0) by_cases hj : (j : ℕ) < N - · rw [dif_pos hj] + · 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 [dif_neg hj] + · rw [dite_eq_right hj] exact fwd_fib_tail g j hj · ext x simp only [Function.comp] @@ -376,7 +376,7 @@ theorem jtChar_pad (μ : YoungDiagram) {k : ℕ} rw [show (if ∀ i : Fin k, 0 ≤ (μ.rowLen (i : ℕ) : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) then _ else (0 : ℂ)) = 0 from by - rw [if_neg] + rw [ite_eq_right] intro hguard exact hσ (fun i hi => tail_fixed_of_guard μ hk σ hguard i (hn_def ▸ hi))] simp @@ -394,7 +394,7 @@ theorem jtChar_pad (μ : YoungDiagram) {k : ℕ} if h : (i : ℕ) < n then jtSigned μ σ' ⟨(i : ℕ), h⟩ else 0 := by intro σ' i by_cases hi : (i : ℕ) < n - · rw [dif_pos hi] + · 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 @@ -403,7 +403,7 @@ theorem jtChar_pad (μ : YoungDiagram) {k : ℕ} have hrow : μ.rowLen (i : ℕ) = μ.rowLens.get ⟨(i : ℕ), hi⟩ := (get_rowLens_eq_rowLen μ ⟨(i : ℕ), hi⟩).symm simp only [jtSigned, hext, hrow] - · rw [dif_neg hi] + · rw [dite_eq_right hi] push Not at hi rw [extendTail_fixes_tail μ hk σ' i hi, rowLen_eq_zero_of_ge μ hi] simp @@ -418,7 +418,7 @@ theorem jtChar_pad (μ : YoungDiagram) {k : ℕ} · intro hbig j have h1 := hbig (Fin.castLE hk j) rw [signed_eq] at h1 - rwa [dif_pos (show (Fin.castLE hk j : ℕ) < n from by + 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 @@ -440,8 +440,8 @@ theorem jtChar_pad (μ : YoungDiagram) {k : ℕ} congr 1; ext i have hsig := signed_eq σ' i by_cases hi : (i : ℕ) < n - · rw [dif_pos hi] at hsig; rw [dif_pos hi, hsig]; rfl - · rw [dif_neg hi] at hsig; rw [dif_neg hi, hsig]; simp + · 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), @@ -464,15 +464,15 @@ theorem jtChar_pad (μ : YoungDiagram) {k : ℕ} intro σ' _ have hfix : tailFix (extendTail μ hk σ') := fun i hi => extendTail_fixes_tail μ hk σ' i hi - rw [dif_pos hfix] + rw [dite_eq_left hfix] exact restrictHead_extendTail μ hk σ' · -- right_inv intro σ hσ - rw [dif_pos (Finset.mem_filter.mp hσ).2] + rw [dite_eq_left (Finset.mem_filter.mp hσ).2] exact extendTail_restrictHead μ hk σ (Finset.mem_filter.mp hσ).2 · -- term matching intro σ' _ - show ((Equiv.Perm.sign σ' : ℤ) : ℂ) * + change ((Equiv.Perm.sign σ' : ℤ) : ℂ) * (if ∀ i, 0 ≤ jtSigned μ σ' i then (colourChar (jtComp μ σ') π : ℂ) else 0) = bigTerm (extendTail μ hk σ') @@ -482,10 +482,10 @@ theorem jtChar_pad (μ : YoungDiagram) {k : ℕ} sign_extendTail μ hk σ'] congr 1 by_cases hguard : ∀ i, 0 ≤ jtSigned μ σ' i - · rw [if_pos hguard, if_pos ((guard_iff σ').mpr hguard)] + · rw [ite_eq_left hguard, ite_eq_left ((guard_iff σ').mpr hguard)] exact_mod_cast (comp_eq σ' hguard).symm - · rw [if_neg hguard, - if_neg (fun h => hguard ((guard_iff σ').mp h))] + · 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 index 4b60bc9c86..232f589af7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTSimple.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTSimple.lean @@ -24,7 +24,7 @@ theorem jtChar_pm_simple (μ : YoungDiagram) : ((∀ π, jtChar μ π = nChar S₀ π) ∨ (∀ π, jtChar μ π = - nChar S₀ π)) := by obtain ⟨J, hJ, ε, T, hT, hε, hchar⟩ := jtChar_eq_sum_sign_nChar μ - letI := hJ + 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 index f1ee627fa4..9c211c43b0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/KillSimples.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/KillSimples.lean @@ -24,14 +24,15 @@ variable {G : Type*} /-- **The faithfulness trick**: killing every simple submodule of the regular module forces vanishing. -/ -theorem eq_zero_of_kills_simples [Group G] [Fintype G] +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 - haveI : NeZero ((Nat.card G : ℂ)) := ⟨by + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedCount.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedCount.lean index 2a8f13ae37..0370af7729 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedCount.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedCount.lean @@ -65,7 +65,7 @@ theorem colourChar_viaEmbedding {m n N : ℕ} (h : m ≤ n) ∀ a, fibreCard p.1.1 a + (univ.filter (fun i : {i : Fin n // m ≤ (i : ℕ)} => p.2 i = a)).card = α a} := by - show (univ.filter _).card = _ + change (univ.filter _).card = _ rw [← Fintype.card_subtype] exact Fintype.card_congr main_equiv rw [lhs_eq, Fintype.card_subtype] @@ -99,7 +99,7 @@ theorem colourChar_viaEmbedding {m n N : ℕ} (h : m ≤ n) refine sum_congr rfl fun w _ => ?_ by_cases hw : ∀ a, w a ≤ α a · -- Case w ≤ α: factor the fibre as product of independent filters - rw [if_pos hw] + rw [ite_eq_left hw] -- Rewrite fibre as product have fibre_eq : S.filter (fun p => cmap p = w) = @@ -127,7 +127,7 @@ theorem colourChar_viaEmbedding {m n N : ℕ} (h : m ≤ n) (fun g => ∀ a, fibreCard g a = α a - w a)).trans (Equiv.subtypeEquivRight (fun _ => And.comm))) · -- Case w ≰ α: fibre is empty - rw [if_neg hw, card_eq_zero, filter_eq_empty_iff] + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedFixed.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedFixed.lean index 3283466bb2..c39f1e7f9e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedFixed.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedFixed.lean @@ -69,7 +69,7 @@ noncomputable def mixedFixedEquiv (h : m ≤ n) (σ : Equiv.Perm (Fin m)) : exact lift_castLE h σ ⟨i, hi⟩ rw [heq] have hσval : (Fin.castLE h (σ ⟨i, hi⟩) : ℕ) < m := (σ ⟨i, hi⟩).2 - rw [dif_pos hσval, dif_pos hi] + 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⟩ @@ -82,14 +82,14 @@ noncomputable def mixedFixedEquiv (h : m ≤ n) (σ : Equiv.Perm (Fin m)) : left_inv f := by apply Subtype.ext; funext i; simp only by_cases hi : (i : ℕ) < m - · rw [dif_pos hi]; simp only [Function.comp_apply]; congr 1 - · rw [dif_neg hi] + · 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 [dif_pos (show (Fin.castLE h j : ℕ) < m from j.2)]; congr 1 + rw [dite_eq_left (show (Fin.castLE h j : ℕ) < m from j.2)]; congr 1 · funext ⟨i, hi⟩; simp only - rw [dif_neg (show ¬ (i : ℕ) < m by omega)] + rw [dite_eq_right (show ¬ (i : ℕ) < m by omega)] /-- The colour counts add across the split. -/ theorem mixedFixedEquiv_symm_fibreCard (h : m ≤ n) @@ -115,17 +115,17 @@ theorem mixedFixedEquiv_symm_fibreCard (h : m ≤ n) refine { toFun := fun ⟨i, hi⟩ => if him : (i : ℕ) < m then - Sum.inl ⟨⟨i, him⟩, by rw [glue_eq, dif_pos him] at hi; exact hi⟩ + 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, dif_neg him] at hi; exact hi⟩ + ⟨⟨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, dif_pos this]; convert hj using 1; exact Fin.ext rfl⟩) + 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, dif_neg this] + rw [glue_eq, dite_eq_right this] exact (congr_arg t (Subtype.ext rfl)).trans hs⟩) left_inv := ?_ right_inv := ?_ } @@ -136,9 +136,9 @@ theorem mixedFixedEquiv_symm_fibreCard (h : m ≤ n) · exact Subtype.ext rfl · rintro (⟨j, hj⟩ | ⟨s, hs⟩) · dsimp only [Sum.elim_inl] - rw [dif_pos (show (Fin.castLE h j : ℕ) < m from j.2)] + 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 [dif_neg (show ¬ (s.1 : ℕ) < m from Nat.not_lt.mpr s.2)] + 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 index ee0b883012..04158d6dce 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeAction.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeAction.lean @@ -42,7 +42,7 @@ instance [Group G] (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) : IsScalarTower ℂ (MonoidAlgebra ℂ G) (subCarrier S) where smul_assoc z y m := by apply Subtype.ext - show ((z • y) • (m : MonoidAlgebra ℂ G)) = + change ((z • y) • (m : MonoidAlgebra ℂ G)) = z • (y • (m : MonoidAlgebra ℂ G)) rw [smul_assoc] @@ -86,7 +86,7 @@ theorem isIrredRep_rhoS IsIrredRep (rhoS S) := by constructor · -- Nontrivial - haveI := IsSimpleModule.nontrivial (MonoidAlgebra ℂ G) S + have := IsSimpleModule.nontrivial (MonoidAlgebra ℂ G) S exact inferInstanceAs (Nontrivial ↥S) · intro p hp -- The invariant ℂ-subspace is a `ℂ[G]`-submodule. diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeFaithful.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeFaithful.lean index 8c89216267..663d4b9482 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeFaithful.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeFaithful.lean @@ -91,12 +91,13 @@ theorem kills_of_equiv_kills_native 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] [DecidableEq G] +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 @@ -104,15 +105,16 @@ theorem natBlock_kills_of_psi_zero [Group G] [Fintype G] [DecidableEq G] · 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, if_neg heq, + 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] [DecidableEq G] +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 @@ -122,7 +124,7 @@ theorem nPsi_projector_eq_one [Group G] [Fintype G] [DecidableEq G] MonoidAlgebra ℂ G) = nProjector S * (m : MonoidAlgebra ℂ G) from rfl] rw [nProjector_mul_mem S S hS hS _ m.2] - rw [if_pos ⟨Representation.Equiv.refl _⟩, one_smul] + rw [ite_eq_left ⟨Representation.Equiv.refl _⟩, one_smul] rfl /-- The native block. -/ @@ -191,10 +193,11 @@ theorem mPsi_zero_iff [Group G] [Fintype G] simp /-- The projector acts as the identity on the carrier. -/ -theorem mPsi_projector_eq_one [Group G] [Fintype G] [DecidableEq G] +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] @@ -230,10 +233,11 @@ noncomputable def mPsiLin [Group G] [Fintype G] simp [mPsi_apply] /-- The coordinate block map is injective. -/ -theorem mPsiLin_injective [Group G] [Fintype G] [DecidableEq G] +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] @@ -251,10 +255,11 @@ theorem mPsiLin_injective [Group G] [Fintype G] [DecidableEq G] /-- 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] [DecidableEq G] +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 @@ -269,7 +274,7 @@ theorem mPsiLin_surjective [Group G] [Fintype G] [DecidableEq G] 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] [DecidableEq G] +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] @@ -278,6 +283,7 @@ theorem nProjector_block_faithful [Group G] [Fintype G] [DecidableEq G] (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 @@ -295,7 +301,7 @@ theorem nProjector_block_faithful [Group G] [Fintype G] [DecidableEq G] exact ⟨a * (nProjector S * x) * (w i : MonoidAlgebra ℂ G), by rw [← ha] - show nProjector S * (a * (nProjector S * x) * + change nProjector S * (a * (nProjector S * x) * (w i : MonoidAlgebra ℂ G)) = nProjector S * a * (nProjector S * x) * (w i : MonoidAlgebra ℂ G) diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeTable.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeTable.lean index e73fc779f4..0a2ec6c49f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeTable.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeTable.lean @@ -61,13 +61,14 @@ theorem mem_subCarrier /-- **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] [DecidableEq G] +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 ℂ @@ -90,9 +91,9 @@ theorem rhoS_isIrreducible (hS : IsSimpleModule (MonoidAlgebra ℂ G) S) : (rhoS S).IsIrreducible := by have hirr := isIrredRep_rhoS S hS - haveI hnt : Nontrivial (Subrepresentation (rhoS S)) := by + have hnt : Nontrivial (Subrepresentation (rhoS S)) := by refine ⟨⟨⊥, ⊤, ?_⟩⟩ - haveI : Nontrivial (subCarrier S) := hirr.1 + have : Nontrivial (subCarrier S) := hirr.1 intro hbt have h1 := congrArg Subrepresentation.toSubmodule hbt have h2 : (⊥ : Submodule ℂ (subCarrier S)) = @@ -120,7 +121,7 @@ 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] [DecidableEq G] +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) @@ -129,15 +130,16 @@ theorem nProjector_mul_mem [Group G] [Fintype G] [DecidableEq G] nProjector S * t = (if Nonempty ((rhoS S).Equiv (rhoS T)) then (1 : ℂ) else 0) • t := by - haveI := rhoS_isIrreducible S hS - haveI := rhoS_isIrreducible T hT + 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 - haveI : Invertible ((Nat.card G : ℂ)) := invertibleOfNonzero hcard0 + 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] @@ -157,13 +159,13 @@ theorem nProjector_mul_mem [Group G] [Fintype G] [DecidableEq G] rw [← horth, ← mul_assoc, mul_inv_cancel₀ hcard, one_mul] rw [hsum, h2] by_cases heq : Nonempty ((rhoS S).Equiv (rhoS T)) - · rw [if_pos heq] + · 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 - haveI : Nontrivial (subCarrier T) := + have : Nontrivial (subCarrier T) := (isIrredRep_rhoS T hT).1 have h1 := Module.finrank_pos (R := ℂ) (M := subCarrier T) @@ -171,15 +173,16 @@ theorem nProjector_mul_mem [Group G] [Fintype G] [DecidableEq G] have hc : ((Fintype.card G : ℂ)) ≠ 0 := by exact_mod_cast Fintype.card_ne_zero field_simp - · rw [if_neg heq] + · rw [ite_eq_right heq] simp open scoped Classical in /-- **Idempotency of the native projector.** -/ -theorem nProjector_idem [Group G] [Fintype G] [DecidableEq G] +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 → @@ -190,36 +193,40 @@ theorem nProjector_idem [Group G] [Fintype G] [DecidableEq G] 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 [if_pos heq, one_smul, one_smul, sub_self] - · rw [if_neg heq] + · 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] [DecidableEq G] +theorem nProjector_central [Group G] [Fintype G] (S : Submodule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G)) (y : MonoidAlgebra ℂ G) : - nProjector S * y = y * nProjector S := - classElem_mul_comm (nCoeff S) (nCoeff_classFun S) y + 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] [DecidableEq G] +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] [DecidableEq G] +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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/OrbitBridge.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/OrbitBridge.lean index 5ea1bd5bba..7990209db9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/OrbitBridge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/OrbitBridge.lean @@ -179,18 +179,18 @@ theorem orbCard_multiset (π : Equiv.Perm (Fin n)) : 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, if_neg (by omega : ¬(1 : ℕ) = 0)] + 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, if_pos rfl] + rw [ct_no_ones, zero_add, ite_eq_left rfl] exact card_singleton_orbits π · -- m ≥ 2 have hm_ge2 : 2 ≤ m := by omega - rw [if_neg (fun h : (1 : ℕ) = m => hm1 h.symm), add_zero] + 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PackageAssembly.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PackageAssembly.lean index dc46fbc22e..6b2ad83e3c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PackageAssembly.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PackageAssembly.lean @@ -62,10 +62,10 @@ noncomputable def schurPackageOf dim := fun μ => nDim (jtSimple μ) char := fun μ => jtChar μ dim_pos := fun μ => by - haveI := jtSimple_simple μ - haveI := IsSimpleModule.nontrivial + have := jtSimple_simple μ + have := IsSimpleModule.nontrivial (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) (jtSimple μ) - haveI : Nontrivial (subCarrier (jtSimple μ)) := + have : Nontrivial (subCarrier (jtSimple μ)) := inferInstanceAs (Nontrivial (jtSimple μ)) exact Module.finrank_pos central := fun μ x => by diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairInner.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairInner.lean index 3d6b48f6a8..43da40dbcb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairInner.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairInner.lean @@ -108,11 +108,11 @@ theorem pair_count_sum (α β : Fin k → ℕ) : 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 [if_pos ⟨hm.1, hm.2, hf⟩, if_pos ⟨hm, hf⟩] - · rw [if_neg (fun hc => hf hc.2.2), - if_neg (fun hc => hf hc.2)] - · rw [if_neg (fun hc => hm ⟨hc.1, hc.2.1⟩), - if_neg (fun hc => hm hc.1)] + · 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) ∧ @@ -129,14 +129,14 @@ theorem pair_count_sum (α β : Fin k → ℕ) : 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 [if_pos hm, Finset.card_filter] + · rw [ite_eq_left hm, Finset.card_filter] refine Finset.sum_congr rfl fun π _ => ?_ by_cases hf : p ∘ π = p - · rw [if_pos ⟨hm, hf⟩, if_pos hf] - · rw [if_neg (fun hc => hf hc.2), if_neg hf] - · rw [if_neg hm] + · 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 π _ => - if_neg (fun hc => hm hc.1)] + 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)] @@ -175,11 +175,11 @@ theorem pair_count_sum (α β : Fin k → ℕ) : 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 [if_pos hm, if_pos (hiff.mp hm)] + · rw [ite_eq_left hm, ite_eq_left (hiff.mp hm)] refine Finset.prod_congr rfl fun c _ => ?_ rw [pairFibre_eq_count] rfl - · rw [if_neg hm, if_neg (fun hc => hm (hiff.mpr hc))]] + · 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) ∧ @@ -210,7 +210,7 @@ theorem pair_count_sum (α β : Fin k → ℕ) : 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 [if_pos hm, if_pos hm] + · 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 @@ -223,7 +223,7 @@ theorem pair_count_sum (α β : Fin k → ℕ) : fun h' => Subtype.ext h'⟩) rw [hc] exact h - · rw [if_neg hm, if_neg hm, mul_zero] + · 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)] diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairOrbit.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairOrbit.lean index 0fd1c2cf50..93800c1119 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairOrbit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairOrbit.lean @@ -41,7 +41,7 @@ theorem content_comp_equiv (p : Fin n → Fin k × Fin k) : (content (finProdFinEquiv ∘ p)).1 = (pairContent p).map finProdFinEquiv := by rw [content, pairContent] - show Finset.univ.val.map (finProdFinEquiv ∘ p) = _ + change Finset.univ.val.map (finProdFinEquiv ∘ p) = _ rw [← Multiset.map_map] open scoped Classical in diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairStab.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairStab.lean index 0b81e0aa1e..7f00adb184 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairStab.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairStab.lean @@ -45,7 +45,7 @@ theorem card_fixing_pairs (p : Fin n → Fin k × Fin k) : · intro h funext i have h1 := congrFun h i - show finProdFinEquiv (p (π i)) = finProdFinEquiv (p 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 = @@ -62,8 +62,8 @@ theorem card_fixing_pairs (p : Fin n → Fin k × Fin k) : rw [fibreCard, pairFibre] congr 1 refine Finset.filter_congr fun i _ => ?_ - show finProdFinEquiv (p i) = j ↔ p i = finProdFinEquiv.symm j - exact Equiv.apply_eq_iff_eq_symm_apply finProdFinEquiv + 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean index bcfa39c2e2..97291dd9bc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean @@ -87,7 +87,8 @@ private theorem inner_sum_eq {m n k : ℕ} (h : m ≤ n) (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 + (∑ 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 @@ -143,9 +144,9 @@ private theorem inner_sum_eq {m n k : ℕ} (h : m ≤ n) else 0) := by intro w _ by_cases hw : ∀ a, w a ≤ α a - · rw [Finset.sum_congr rfl fun σ _ => by rw [if_pos hw]] + · rw [Finset.sum_congr rfl fun σ _ => by rw [ite_eq_left hw]] rw [← Finset.sum_mul] - rw [if_pos hw] + rw [ite_eq_left hw] congr 1 -- ∑_σ cc(β,σ) * cc(α-w,σ) as ℂ = (∑_σ cc(β,σ)*cc(α-w,σ) as ℕ) as ℂ -- = (∑_σ |pairs|) as ℂ via colourChar_mul @@ -161,7 +162,7 @@ private theorem inner_sum_eq {m n k : ℕ} (h : m ≤ n) rw [pair_tuple_card β (fun a => α a - w a) hβ] -- Cast to ℂ exact_mod_cast hnat - · rw [if_neg hw, Finset.sum_eq_zero fun σ _ => by rw [if_neg hw]] + · 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, @@ -192,7 +193,7 @@ private theorem inner_sum_eq {m n k : ℕ} (h : m ≤ n) (Finset.mem_univ a); exact this)] refine Finset.sum_congr rfl fun w _ => ?_ by_cases hw : ∀ a, w a ≤ α a - · rw [if_pos hw, if_pos hw] + · 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 @@ -209,7 +210,7 @@ private theorem inner_sum_eq {m n k : ℕ} (h : m ≤ n) simp_rw [sum_single_apply] norm_cast convert rfl using 5 - · rw [if_neg hw, if_neg hw] + · 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 @@ -238,8 +239,8 @@ private theorem coeff_det_jtMat_mul {k : ℕ} MvPolynomial.coeff_C_mul] by_cases hp : ∀ i : Fin k, 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) - · rw [if_pos hp, if_pos hp] - · rw [if_neg hp, if_neg hp, zero_mul, MvPolynomial.coeff_zero] + · 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 @@ -289,7 +290,8 @@ private theorem pairing_eq_factorial_coeff ∑ τ : 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)) + 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)) = @@ -303,25 +305,26 @@ private theorem pairing_eq_factorial_coeff rw [coeff_mul_alternant] refine Finset.sum_congr rfl fun τ _ => ?_ by_cases hτ : stairShift τ ≤ diagExp vm - · rw [if_pos hτ, coeff_det_jtMat_mul, Finset.mul_sum] + · 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, if_pos hσ, if_pos ⟨hguard_mu, hσ⟩, hmargin] - · rw [mul_assoc, if_neg hσ, if_neg (fun ⟨_, h⟩ => hσ h), mul_zero] - · rw [if_neg hτ] + 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)) + 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 [if_neg (fun ⟨h, _⟩ => hguard_mu_neg h)]; ring + 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 : @@ -330,7 +333,8 @@ private theorem pairing_eq_factorial_coeff ∑ σ' : 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)) + then ((∏ i, hSub (Finset.univ : Finset (Fin k)) (β σ' i)) * Q).coeff (∑ a, + Finsupp.single a (α τ a)) else 0) := by -- Expand restrPairing unfold restrPairing @@ -359,8 +363,8 @@ private theorem pairing_eq_factorial_coeff · have hτ_exp : ∀ i : Fin k, (0 : ℤ) ≤ ↑(mu.rowLen ↑i) + ↑↑(τ i) - ↑↑i := hτ -- Both guards hold: apply inner_sum_eq - simp_rw [if_pos hσ_exp, if_pos hτ_exp] - rw [if_pos ⟨hσ, hτ⟩] + 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] @@ -383,14 +387,14 @@ private theorem pairing_eq_factorial_coeff · -- guard_mu fails have hτ_exp : ¬ ∀ i : Fin k, (0 : ℤ) ≤ ↑(mu.rowLen ↑i) + ↑↑(τ i) - ↑↑i := hτ - simp_rw [if_pos hσ_exp, if_neg hτ_exp] - rw [if_neg (fun ⟨_, h⟩ => hτ 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 [if_neg hσ_exp] - rw [if_neg (fun ⟨h, _⟩ => hσ 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PermModule.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PermModule.lean index 6cf75f7c07..b1d85b8006 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PermModule.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PermModule.lean @@ -19,7 +19,7 @@ namespace RS open Finset Equiv MonoidAlgebra -open scoped Classical + /-- The colour class: colourings with prescribed fibre sizes. -/ def colourClass (n : ℕ) {N : ℕ} (α : Fin N → ℕ) : Type := @@ -43,11 +43,11 @@ instance colourClass.mulAction {n N : ℕ} (α : Fin N → ℕ) : rw [fibreCard_comp_perm]; exact g.2 j⟩ one_smul g := by apply Subtype.ext - show g.1 ∘ ⇑(1 : Equiv.Perm (Fin n))⁻¹ = g.1 + change g.1 ∘ ⇑(1 : Equiv.Perm (Fin n))⁻¹ = g.1 simp mul_smul π ρ g := by apply Subtype.ext - show g.1 ∘ ⇑(π * ρ)⁻¹ = (⟨(g.1 ∘ ⇑ρ⁻¹) ∘ ⇑π⁻¹, _⟩ : colourClass n α).1 + change g.1 ∘ ⇑(π * ρ)⁻¹ = (⟨(g.1 ∘ ⇑ρ⁻¹) ∘ ⇑π⁻¹, _⟩ : colourClass n α).1 rw [mul_inv_rev] rfl @@ -109,12 +109,12 @@ theorem colourRep_character {n N : ℕ} (α : Fin N → ℕ) (π : Equiv.Perm (Fin n)) : (colourRep α).character π = (colourChar α π : ℂ) := by -- character = trace of the linear map - show LinearMap.trace ℂ _ ((colourRep α) π) = _ + 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 - show ∑ g : colourClass n α, + change ∑ g : colourClass n α, LinearMap.toMatrix b b ((colourRep α) π) g g = _ -- compute each diagonal entry have hdiag : ∀ g : colourClass n α, @@ -130,11 +130,11 @@ theorem colourRep_character {n N : ℕ} (α : Fin N → ℕ) MonoidAlgebra.single (π • g) 1 from Representation.ofMulAction_single π g 1] -- b.repr = coeffLinearEquiv - show ((coeffLinearEquiv ℂ) + change ((coeffLinearEquiv ℂ) (MonoidAlgebra.single (π • g) (1 : ℂ))) g = if π • g = g then 1 else 0 rw [coeffLinearEquiv_apply] - simp [MonoidAlgebra.coeff, Finsupp.single_apply, eq_comm] + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PowerSurj.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PowerSurj.lean index e3a442dd29..7c402b3d8e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PowerSurj.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PowerSurj.lean @@ -124,7 +124,7 @@ theorem ePoly_coeff {t : ℕ → ℂ} {n k : ℕ} (hk : k ≤ n) : omega) rfl rfl)] rw [Finset.sum_ite_eq' (range (n + 1)) k (fun j => ((-1 : ℂ)) ^ j * eSeq t j)] - rw [if_pos (Finset.mem_range.mpr (by omega))] + rw [ite_eq_left (Finset.mem_range.mpr (by omega))] /-- Its leading coefficient is `1`. -/ theorem ePoly_coeff_self (t : ℕ → ℂ) (n : ℕ) : diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/RegularTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/RegularTrace.lean index eef81fa95a..f957b92422 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/RegularTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/RegularTrace.lean @@ -23,7 +23,7 @@ variable {G : Type*} /-- **The regular trace**: left multiplication by `y` has trace `|G| · y 1`. -/ -theorem trace_mulLeft [Group G] [Fintype G] [DecidableEq G] +theorem trace_mulLeft [Group G] [Fintype G] (y : MonoidAlgebra ℂ G) : LinearMap.trace ℂ (MonoidAlgebra ℂ G) (mulLeft ℂ y) = (Fintype.card G : ℂ) * y.coeff 1 := by @@ -40,13 +40,13 @@ theorem trace_mulLeft [Group G] [Fintype G] [DecidableEq 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.mul_single_apply y 1 g g] + 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] [DecidableEq G] +theorem finrank_range_mulLeft [Group G] [Fintype G] (y : MonoidAlgebra ℂ G) (hy : y * y = y) : (Module.finrank ℂ (LinearMap.range (mulLeft ℂ y)) : ℂ) = diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SameCycleQuot.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SameCycleQuot.lean index 08a20a9d0b..8d0b01cee5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SameCycleQuot.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SameCycleQuot.lean @@ -96,7 +96,7 @@ theorem fixed_comp_zpow {C : Type*} {f : Fin n → C} rw [show (π ^ ((k : ℤ) + 1) : Equiv.Perm (Fin n)) = (π ^ (k : ℤ)) * π from by rw [zpow_add, zpow_one]] rfl - show f ((π ^ ((k : ℤ) + 1) : Equiv.Perm (Fin n)) a) = f a + 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 @@ -110,7 +110,7 @@ theorem fixed_comp_zpow {C : Type*} {f : Fin n → C} (π ^ (-k : ℤ)) * π⁻¹ from by rw [zpow_sub, zpow_one]] rfl - show f ((π ^ ((-k : ℤ) - 1) : Equiv.Perm (Fin n)) a) = f a + 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 @@ -130,7 +130,7 @@ noncomputable def fixedFunEquiv (C : Type*) : exact this.symm ▸ this.symm ▸ this) invFun g := ⟨fun i => g (orbitOf π i), by funext i - show g (orbitOf π (π i)) = g (orbitOf π 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ScalarTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ScalarTrace.lean index 926d67503b..2a77ce7364 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ScalarTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ScalarTrace.lean @@ -46,7 +46,7 @@ theorem trace_asAlgebraHom_classElem acts on an irreducible representation as the character-pairing scalar divided by the dimension. -/ theorem classElem_scalar_eq - [Group G] [Fintype G] [DecidableEq G] [AddCommGroup V] [Module ℂ V] + [Group G] [Fintype G] [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V] {ρ : Representation ℂ G V} (hirr : IsIrredRep ρ) (c : G → ℂ) @@ -54,11 +54,12 @@ theorem classElem_scalar_eq ρ.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 - haveI : Nontrivial V := hirr.1 + have : Nontrivial V := hirr.1 have hdim : (Module.finrank ℂ V : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr Module.finrank_pos.ne' congr 1 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SchurAction.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SchurAction.lean index 54906bda85..51fed9b0c9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SchurAction.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SchurAction.lean @@ -38,7 +38,7 @@ theorem commuting_scalar (hT : ∀ g : G, T ∘ₗ (ρ g : V →ₗ[ℂ] V) = (ρ g : V →ₗ[ℂ] V) ∘ₗ T) : ∃ c : ℂ, T = c • LinearMap.id := by - haveI : Nontrivial V := hirr.1 + have : Nontrivial V := hirr.1 obtain ⟨c, hc⟩ := Module.End.exists_eigenvalue T refine ⟨c, ?_⟩ have hker : LinearMap.ker (T - c • LinearMap.id) ≠ ⊥ := by @@ -83,11 +83,12 @@ theorem commuting_scalar /-- The image of a class-function element commutes with the action. -/ theorem asAlgebraHom_classElem_comm - [Group G] [Fintype G] [DecidableEq G] [AddCommGroup V] [Module ℂ V] + [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] @@ -100,12 +101,14 @@ theorem asAlgebraHom_classElem_comm /-- **Scalar action**: a class-function element acts as a scalar on every irreducible representation. -/ theorem asAlgebraHom_classElem_scalar - [Group G] [Fintype G] [DecidableEq G] [AddCommGroup V] [Module ℂ V] + [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 := - commuting_scalar hirr _ (asAlgebraHom_classElem_comm ρ c hc) + ∃ 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/SignedTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean index 777da2722a..31ad3a6694 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean @@ -66,7 +66,7 @@ theorem sign_mul_cycleProd_const {n : ℕ} (m : ℕ) set K := c + (n - s) have hsn : s ≤ n := by have := Equiv.Perm.sum_cycleType_le π - simp [Fintype.card_fin] at this + simp? [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 := diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean index d11ea3da1d..ad94d64dbf 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean @@ -21,14 +21,16 @@ variable {G : Type*} /-- Every simple `ℂ[G]`-module is isomorphic to a simple submodule of the regular module. -/ -theorem exists_simple_submodule_linearEquiv [Group G] [Fintype G] +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. - haveI := IsSimpleModule.nontrivial (MonoidAlgebra ℂ G) 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 := @@ -42,7 +44,7 @@ theorem exists_simple_submodule_linearEquiv [Group G] [Fintype G] have h1 : φ 1 ∈ range φ := mem_range_self φ 1 have h1bot := h h1 rw [Submodule.mem_bot] at h1bot - simp [φ, toSpanSingleton, smulRight] at h1bot + simp? [φ, toSpanSingleton, smulRight] at h1bot exact hm h1bot rcases hM.eq_bot_or_eq_top (range φ) with h | h · exact absurd h hne @@ -50,10 +52,10 @@ theorem exists_simple_submodule_linearEquiv [Group G] [Fintype G] -- The kernel K := ker φ. let K := ker φ -- By Maschke / semisimplicity, K has a complement S. - haveI : NeZero ((Nat.card G : ℂ)) := ⟨by + have : NeZero ((Nat.card G : ℂ)) := ⟨by rw [Nat.card_eq_fintype_card] exact_mod_cast Fintype.card_ne_zero⟩ - haveI : IsSemisimpleModule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G) + have : IsSemisimpleModule (MonoidAlgebra ℂ G) (MonoidAlgebra ℂ G) := inferInstance obtain ⟨S, hcompl⟩ := exists_isCompl K -- Build the linear equivalence S ≃ₗ M. diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorTrace.lean index 2e81265ff5..bcae3c4eed 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorTrace.lean @@ -20,7 +20,7 @@ namespace RS open Finset Equiv MonoidAlgebra -open scoped Classical + /-! ## The permutation action on the full function space -/ @@ -30,10 +30,10 @@ instance tensorAction (n m : ℕ) : MulAction (Equiv.Perm (Fin n)) (Fin n → Fin m) where smul π g := g ∘ ⇑π⁻¹ one_smul g := by - show g ∘ ⇑(1 : Equiv.Perm (Fin n))⁻¹ = g + change g ∘ ⇑(1 : Equiv.Perm (Fin n))⁻¹ = g simp mul_smul π ρ g := by - show g ∘ ⇑(π * ρ)⁻¹ = (g ∘ ⇑ρ⁻¹) ∘ ⇑π⁻¹ + change g ∘ ⇑(π * ρ)⁻¹ = (g ∘ ⇑ρ⁻¹) ∘ ⇑π⁻¹ rw [mul_inv_rev] rfl diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/WordCommutant.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/WordCommutant.lean index 616936b38f..979b6f980c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/WordCommutant.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/WordCommutant.lean @@ -19,7 +19,7 @@ lies between zero and the word length, giving the polynomial bound namespace RS open Finset Representation -open scoped Classical + noncomputable section @@ -37,6 +37,7 @@ structure MonomialWordAction /-- 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, @@ -44,6 +45,7 @@ private def wordPairCounts (p : (Fin n → α) × (Fin n → α)) : (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) : @@ -62,6 +64,7 @@ private theorem wordPairCounts_eq_imp_perm · 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 ρ) @@ -90,6 +93,7 @@ private theorem monomial_intertwining_entry 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 → α) → ℂ)) : @@ -100,21 +104,22 @@ private def commutantEntries map_add' T U := by funext c by_cases h : ∃ p, wordPairCounts p = c - · simp only [dif_pos h, Pi.add_apply] + · simp only [dite_eq_left h, Pi.add_apply] rfl - · simp only [dif_neg h, Pi.add_apply, add_zero] + · 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 [dif_pos h, Pi.smul_apply, RingHom.id_apply] + · simp only [dite_eq_left h, Pi.smul_apply, RingHom.id_apply] rfl - · simp only [dif_neg h, Pi.smul_apply, smul_zero] + · simp only [dite_eq_right h, Pi.smul_apply, smul_zero] -private theorem commutantEntries_injective [Fintype α] +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 @@ -125,7 +130,7 @@ private theorem commutantEntries_injective [Fintype α] Classical.choose_spec hc have hz := congrFun hT c simp only [commutantEntries, LinearMap.coe_mk, AddHom.coe_mk, - dif_pos hc, Pi.zero_apply] at hz + 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 @@ -137,6 +142,7 @@ private theorem commutantEntries_injective [Fintype α] 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 α] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourAction.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourAction.lean index 8e02889051..67efeea492 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourAction.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourAction.lean @@ -33,14 +33,14 @@ theorem toColour_powBraid : | n + 2, i, h => by by_cases hi : i = n · rw [show powBraid (stdSuperPair k ℓ) (n + 2) i h = - topBraid (stdSuperPair k ℓ) n from dif_pos hi] + 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 dif_neg hi] + stdSuperPair k ℓ from dite_eq_right hi] rw [toColour_whisker] rw [toColour_powBraid (n + 1) i hle] rw [colourExtend_colourSwap] @@ -53,7 +53,7 @@ theorem toColour_powBraidWord {n : ℕ} (w : List (Fin n)) : induction w with | nil => exact toColour_id (n + 1) | cons i w ih => - show toColour (n + 1) (powBraidWord (stdSuperPair k ℓ) w ≫ + change toColour (n + 1) (powBraidWord (stdSuperPair k ℓ) w ≫ powBraid (stdSuperPair k ℓ) (n + 1) i.val (by omega)) = _ rw [toColour_comp, ih, toColour_powBraid] rfl diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConj.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConj.lean index 1df98b43d9..858b244dd9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConj.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConj.lean @@ -61,11 +61,11 @@ theorem toColour_comp (n : ℕ) toColour n g₁ ≫ toColour n g₂ := by refine SuperVect.Hom.ext ?_ ?_ · refine LinearMap.ext (fun x => ?_) - show (colourPowerEquiv k ℓ n).evenEquiv + change (colourPowerEquiv k ℓ n).evenEquiv ((g₂ : SuperVect.Hom _ _).evenMap ((g₁ : SuperVect.Hom _ _).evenMap ((colourPowerEquiv k ℓ n).evenEquiv.symm x))) = _ - show _ = (colourPowerEquiv k ℓ n).evenEquiv + change _ = (colourPowerEquiv k ℓ n).evenEquiv ((g₂ : SuperVect.Hom _ _).evenMap ((colourPowerEquiv k ℓ n).evenEquiv.symm ((colourPowerEquiv k ℓ n).evenEquiv @@ -73,11 +73,11 @@ theorem toColour_comp (n : ℕ) ((colourPowerEquiv k ℓ n).evenEquiv.symm x))))) rw [(colourPowerEquiv k ℓ n).evenEquiv.symm_apply_apply] · refine LinearMap.ext (fun x => ?_) - show (colourPowerEquiv k ℓ n).oddEquiv + change (colourPowerEquiv k ℓ n).oddEquiv ((g₂ : SuperVect.Hom _ _).oddMap ((g₁ : SuperVect.Hom _ _).oddMap ((colourPowerEquiv k ℓ n).oddEquiv.symm x))) = _ - show _ = (colourPowerEquiv k ℓ n).oddEquiv + change _ = (colourPowerEquiv k ℓ n).oddEquiv ((g₂ : SuperVect.Hom _ _).oddMap ((colourPowerEquiv k ℓ n).oddEquiv.symm ((colourPowerEquiv k ℓ n).oddEquiv @@ -90,11 +90,11 @@ theorem toColour_id (n : ℕ) : toColour (k := k) (ℓ := ℓ) n (𝟙 _) = 𝟙 _ := by refine SuperVect.Hom.ext ?_ ?_ · refine LinearMap.ext (fun x => ?_) - show (colourPowerEquiv k ℓ n).evenEquiv + 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 => ?_) - show (colourPowerEquiv k ℓ n).oddEquiv + change (colourPowerEquiv k ℓ n).oddEquiv ((colourPowerEquiv k ℓ n).oddEquiv.symm x) = x rw [(colourPowerEquiv k ℓ n).oddEquiv.apply_symm_apply] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjStep.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjStep.lean index 6ae330c1c1..cd786f0653 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjStep.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjStep.lean @@ -34,8 +34,7 @@ private lemma congr_refl_map_id {M₁ M₂ N : Type*} ((TensorProduct.congr E (LinearEquiv.refl ℂ N)).symm t)) = TensorProduct.map (E.toLinearMap ∘ₗ f ∘ₗ E.symm.toLinearMap) LinearMap.id t := by - induction t using TensorProduct.induction_on with - | zero => simp + induction t using TensorProduct.inductionOn with | tmul a b => simp only [TensorProduct.congr_symm_tmul, TensorProduct.map_tmul, LinearEquiv.coe_toLinearMap, LinearMap.comp_apply, @@ -56,7 +55,7 @@ theorem toColour_whisker {k ℓ : ℕ} (n : ℕ) · -- Even component refine LinearMap.ext (fun x => ?_) -- Expand colourPowerEquiv (n+1) = (tensorCongr CPE refl).trans step - show ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ n) + change ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ n) (SuperLinearEquiv.refl (stdSuperPair k ℓ))).evenEquiv.trans (colourPowerStep k ℓ n).evenEquiv) ((g ▷ stdSuperPair k ℓ : SuperVect.Hom _ _).evenMap @@ -80,7 +79,7 @@ theorem toColour_whisker {k ℓ : ℕ} (n : ℕ) exact Prod.ext (congr_refl_map_id _ _ y₁) (congr_refl_map_id _ _ y₂) · -- Odd component (symmetric) refine LinearMap.ext (fun x => ?_) - show ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ n) + change ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ n) (SuperLinearEquiv.refl (stdSuperPair k ℓ))).oddEquiv.trans (colourPowerStep k ℓ n).oddEquiv) ((g ▷ stdSuperPair k ℓ : SuperVect.Hom _ _).oddMap diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean index 7095b00153..acdac815c1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean @@ -27,8 +27,7 @@ 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.induction_on with - | zero => rfl + 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] @@ -41,7 +40,7 @@ private theorem eval1_even_inl (r : ℂ) (i : Fin k) (hi : c₁ (Fin.last 0) = Sum.inl i) : (colourPowerEquiv k ℓ 1).evenEquiv (evenPair r x) ⟨c₁, h₁⟩ = r * x i := by - show (colourPowerStep k ℓ 0).evenEquiv + change (colourPowerStep k ℓ 0).evenEquiv ((TensorProduct.congr (colourPowerEquiv k ℓ 0).evenEquiv (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even)) @@ -61,7 +60,7 @@ private theorem eval1_even_inl (r : ℂ) ((colourPowerEquiv k ℓ 0).evenEquiv r) ⊗ₜ[ℂ] x := Eq.trans (TensorProduct.congr_tmul _ _ _ _) (by rfl) rw [hcongr, map_zero] - show Sum.elim + change Sum.elim (fun p => funTensorFun _ _ (((colourPowerEquiv k ℓ 0).evenEquiv r) ⊗ₜ[ℂ] (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even x)) p) @@ -83,7 +82,7 @@ private theorem eval1_even_zero (r : ℂ) (b : Fin (2 * ℓ)) (hb : c₁ (Fin.last 0) = Sum.inr b) : (colourPowerEquiv k ℓ 1).evenEquiv (evenPair r x) ⟨c₁, h₁⟩ = 0 := by - show (colourPowerStep k ℓ 0).evenEquiv + change (colourPowerStep k ℓ 0).evenEquiv ((TensorProduct.congr (colourPowerEquiv k ℓ 0).evenEquiv (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even)) @@ -103,7 +102,7 @@ private theorem eval1_even_zero (r : ℂ) ((colourPowerEquiv k ℓ 0).evenEquiv r) ⊗ₜ[ℂ] x := Eq.trans (TensorProduct.congr_tmul _ _ _ _) (by rfl) rw [hcongr, map_zero] - show Sum.elim + change Sum.elim (fun p => funTensorFun _ _ (((colourPowerEquiv k ℓ 0).evenEquiv r) ⊗ₜ[ℂ] (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even x)) p) @@ -125,7 +124,7 @@ private theorem eval1_odd_inr (r : ℂ) (((r ⊗ₜ[ℂ] w, 0) : (superPow (stdSuperPair k ℓ) 1).odd)) ⟨c₁, h₁⟩ = r * w a := by - show (colourPowerStep k ℓ 0).oddEquiv + change (colourPowerStep k ℓ 0).oddEquiv ((TensorProduct.congr (colourPowerEquiv k ℓ 0).evenEquiv (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd)) @@ -145,7 +144,7 @@ private theorem eval1_odd_inr (r : ℂ) ((colourPowerEquiv k ℓ 0).evenEquiv r) ⊗ₜ[ℂ] w := Eq.trans (TensorProduct.congr_tmul _ _ _ _) (by rfl) rw [hcongr, map_zero] - show Sum.elim + change Sum.elim (fun p => funTensorFun _ _ (((colourPowerEquiv k ℓ 0).evenEquiv r) ⊗ₜ[ℂ] (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd w)) p) @@ -184,7 +183,7 @@ private theorem eval1_odd_zero (r : ℂ) (colourPowerEquiv k ℓ 1).oddEquiv (((r ⊗ₜ[ℂ] w, 0) : (superPow (stdSuperPair k ℓ) 1).odd)) ⟨c₁, h₁⟩ = 0 := by - show (colourPowerStep k ℓ 0).oddEquiv + change (colourPowerStep k ℓ 0).oddEquiv ((TensorProduct.congr (colourPowerEquiv k ℓ 0).evenEquiv (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd)) @@ -204,7 +203,7 @@ private theorem eval1_odd_zero (r : ℂ) ((colourPowerEquiv k ℓ 0).evenEquiv r) ⊗ₜ[ℂ] w := Eq.trans (TensorProduct.congr_tmul _ _ _ _) (by rfl) rw [hcongr, map_zero] - show Sum.elim + change Sum.elim (fun p => funTensorFun _ _ (((colourPowerEquiv k ℓ 0).evenEquiv r) ⊗ₜ[ℂ] (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd w)) p) @@ -248,7 +247,7 @@ private theorem eval2_ee (r : ℂ) (x y : (stdSuperPair k ℓ).even) (0 : ({c : MixedColouring k ℓ 1 // ¬ c.IsEven} → ℂ) ⊗[ℂ] (Fin (2 * ℓ) → ℂ)) q) (evenSplitEquiv k ℓ 1 ⟨c, hc⟩) := by - show (colourPowerStep k ℓ 1).evenEquiv + change (colourPowerStep k ℓ 1).evenEquiv ((TensorProduct.congr (colourPowerEquiv k ℓ 1).evenEquiv (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even)) @@ -344,7 +343,7 @@ private theorem eval2_oo (r : ℂ) (superPow (stdSuperPair k ℓ) 1).odd))) ⊗ₜ[ℂ] (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd z)) q) (evenSplitEquiv k ℓ 1 ⟨c, hc⟩) := by - show (colourPowerStep k ℓ 1).evenEquiv + change (colourPowerStep k ℓ 1).evenEquiv ((TensorProduct.congr (colourPowerEquiv k ℓ 1).evenEquiv (LinearEquiv.refl ℂ (stdSuperPair k ℓ).even)) @@ -452,7 +451,7 @@ private theorem whisker_unit_even' {V W : SuperVect} V.odd))) = ((r ⊗ₜ[ℂ] g.evenMap z, (0 : SuperVect.tensorUnit.odd ⊗[ℂ] W.odd))) := by - show (TensorProduct.map + change (TensorProduct.map (SuperVect.Hom.id SuperVect.tensorUnit).evenMap g.evenMap (r ⊗ₜ[ℂ] z), TensorProduct.map @@ -580,159 +579,32 @@ private theorem colourFun_neg_apply {n : ℕ} -- Raised budget: 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 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 - haveI : Subsingleton SuperVect.tensorUnit.odd := - inferInstanceAs (Subsingleton PUnit) - haveI : 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 - show 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] - show (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), +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))) := 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 if_neg (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), + (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)) := 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 if_pos ⟨(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. + (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.induction_on with - | zero => exact hP0 + induction v₁ using TensorProduct.inductionOn with | add s t hs ht => rw [show ((s + t, 0) : (superPow (stdSuperPair k ℓ) 2).even) = @@ -771,26 +643,7 @@ private theorem braid_coord_even exact Prod.ext_iff.mpr ⟨rfl, (add_zero 0).symm⟩ refine Eq.mpr (congrArg P helem) (hPadd _ _ ?_ ?_) · clear helem - induction a₁ using TensorProduct.induction_on with - | zero => - have h0elem : (((((0 : - (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] - (stdSuperPair k ℓ).even), 0) : - (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] y, - 0) : (superPow (stdSuperPair k ℓ) 2).even) = - 0 := by - refine Eq.trans (congrArg (fun t => - ((t, (0 : (superPow (stdSuperPair k ℓ) 1).odd - ⊗[ℂ] (stdSuperPair k ℓ).odd)) : - (superPow (stdSuperPair k ℓ) 2).even)) - (show ((((0 : - (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] - (stdSuperPair k ℓ).even), 0) : - (superPow (stdSuperPair k ℓ) 1).even)) - ⊗ₜ[ℂ] y = 0 from - TensorProduct.zero_tmul _ y)) ?_ - exact Prod.ext_iff.mpr ⟨rfl, rfl⟩ - exact Eq.mpr (congrArg P h0elem) hP0 + induction a₁ using TensorProduct.inductionOn with | add s t hs ht => have helem : (((((s + t : (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] @@ -832,31 +685,14 @@ private theorem braid_coord_even (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] y, 0) : (superPow (stdSuperPair k ℓ) 2).even) = 0 := by - refine Eq.trans (congrArg (fun t => - ((((((0 : (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] - (stdSuperPair k ℓ).even), t) : - (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] y), - (0 : (superPow (stdSuperPair k ℓ) 1).odd - ⊗[ℂ] (stdSuperPair k ℓ).odd)) : - (superPow (stdSuperPair k ℓ) 2).even)) - (subsingleton_tmul_eq_zero a₂)) ?_ - refine Eq.trans (congrArg (fun t => - ((t, (0 : (superPow (stdSuperPair k ℓ) 1).odd - ⊗[ℂ] (stdSuperPair k ℓ).odd)) : - (superPow (stdSuperPair k ℓ) 2).even)) - (show ((((0 : - (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] - (stdSuperPair k ℓ).even), (0 : - (superPow (stdSuperPair k ℓ) 0).odd ⊗[ℂ] - (stdSuperPair k ℓ).odd)) : - (superPow (stdSuperPair k ℓ) 1).even)) - ⊗ₜ[ℂ] y = 0 from - TensorProduct.zero_tmul _ y)) ?_ - exact Prod.ext_iff.mpr ⟨rfl, rfl⟩ + 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.induction_on with - | zero => exact hP0 + induction v₂ using TensorProduct.inductionOn with | add s t hs ht => rw [show ((0, s + t) : (superPow (stdSuperPair k ℓ) 2).even) = @@ -895,25 +731,7 @@ private theorem braid_coord_even exact Prod.ext_iff.mpr ⟨(add_zero 0).symm, rfl⟩ refine Eq.mpr (congrArg P helem) (hPadd _ _ ?_ ?_) · clear helem - induction b₁ using TensorProduct.induction_on with - | zero => - have h0elem : ((0, ((((0 : - (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] - (stdSuperPair k ℓ).odd), 0) : - (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z)) : - (superPow (stdSuperPair k ℓ) 2).even) = 0 := by - refine Eq.trans (congrArg (fun t => - (((0 : (superPow (stdSuperPair k ℓ) 1).even - ⊗[ℂ] (stdSuperPair k ℓ).even), t) : - (superPow (stdSuperPair k ℓ) 2).even)) - (show ((((0 : - (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] - (stdSuperPair k ℓ).odd), 0) : - (superPow (stdSuperPair k ℓ) 1).odd)) - ⊗ₜ[ℂ] z = 0 from - TensorProduct.zero_tmul _ z)) ?_ - exact Prod.ext_iff.mpr ⟨rfl, rfl⟩ - exact Eq.mpr (congrArg P h0elem) hP0 + induction b₁ using TensorProduct.inductionOn with | add s t hs ht => have helem : ((0, ((((s + t : (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] @@ -956,86 +774,217 @@ private theorem braid_coord_even (stdSuperPair k ℓ).odd), b₂) : (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z)) : (superPow (stdSuperPair k ℓ) 2).even) = 0 := by - refine Eq.trans (congrArg (fun t => - (((0 : (superPow (stdSuperPair k ℓ) 1).even - ⊗[ℂ] (stdSuperPair k ℓ).even), - ((((0 : (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] - (stdSuperPair k ℓ).odd), t) : - (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] z)) : - (superPow (stdSuperPair k ℓ) 2).even)) - (subsingleton_tmul_eq_zero b₂)) ?_ - refine Eq.trans (congrArg (fun t => - (((0 : (superPow (stdSuperPair k ℓ) 1).even - ⊗[ℂ] (stdSuperPair k ℓ).even), t) : - (superPow (stdSuperPair k ℓ) 2).even)) - (show ((((0 : - (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] - (stdSuperPair k ℓ).odd), (0 : - (superPow (stdSuperPair k ℓ) 0).odd ⊗[ℂ] - (stdSuperPair k ℓ).even)) : - (superPow (stdSuperPair k ℓ) 1).odd)) - ⊗ₜ[ℂ] z = 0 from - TensorProduct.zero_tmul _ z)) ?_ - exact Prod.ext_iff.mpr ⟨rfl, rfl⟩ + 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 -/-! ### 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 - show (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, +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 ℓ).even))) : - (superPow (stdSuperPair k ℓ) 2).odd) ⟨c, hc⟩ = + (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] @@ -1155,7 +1104,7 @@ private theorem eval2_oe (r : ℂ) (u : (stdSuperPair k ℓ).odd) (LinearEquiv.refl ℂ (Fin k → ℂ) y)) q) ((Equiv.sumComm _ _).symm (oddSplitEquiv k ℓ 1 ⟨c, hc⟩)) := by - show (colourPowerStep k ℓ 1).oddEquiv + change (colourPowerStep k ℓ 1).oddEquiv ((TensorProduct.congr (colourPowerEquiv k ℓ 1).evenEquiv (LinearEquiv.refl ℂ (stdSuperPair k ℓ).odd)) @@ -1305,7 +1254,7 @@ private theorem whisker_unit_odd' {V W : SuperVect} V.even))) = ((r ⊗ₜ[ℂ] g.oddMap z, (0 : SuperVect.tensorUnit.odd ⊗[ℂ] W.even))) := by - show (TensorProduct.map + change (TensorProduct.map (SuperVect.Hom.id SuperVect.tensorUnit).evenMap g.oddMap (r ⊗ₜ[ℂ] z), TensorProduct.map @@ -1420,163 +1369,34 @@ private theorem colourFunO_add_apply {n : ℕ} -- As for the even component: the same two-strand coordinate -- elaborated through the odd half of the colouring equivalence. -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 - haveI : Subsingleton SuperVect.tensorUnit.odd := - inferInstanceAs (Subsingleton PUnit) - haveI : 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 - show 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] - show (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) +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)))) := 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 if_neg (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) + (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))) := 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 if_neg (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. + (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.induction_on with - | zero => exact hP0 + induction v₁ using TensorProduct.inductionOn with | add s t hs ht => rw [show ((s + t, 0) : (superPow (stdSuperPair k ℓ) 2).odd) = @@ -1615,26 +1435,7 @@ private theorem braid_coord_odd exact Prod.ext_iff.mpr ⟨rfl, (add_zero 0).symm⟩ refine Eq.mpr (congrArg P helem) (hPadd _ _ ?_ ?_) · clear helem - induction a₁ using TensorProduct.induction_on with - | zero => - have h0elem : (((((0 : - (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] - (stdSuperPair k ℓ).even), 0) : - (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, - 0) : (superPow (stdSuperPair k ℓ) 2).odd) = - 0 := by - refine Eq.trans (congrArg (fun t => - ((t, (0 : (superPow (stdSuperPair k ℓ) 1).odd - ⊗[ℂ] (stdSuperPair k ℓ).even)) : - (superPow (stdSuperPair k ℓ) 2).odd)) - (show ((((0 : - (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] - (stdSuperPair k ℓ).even), 0) : - (superPow (stdSuperPair k ℓ) 1).even)) - ⊗ₜ[ℂ] w = 0 from - TensorProduct.zero_tmul _ w)) ?_ - exact Prod.ext_iff.mpr ⟨rfl, rfl⟩ - exact Eq.mpr (congrArg P h0elem) hP0 + induction a₁ using TensorProduct.inductionOn with | add s t hs ht => have helem : (((((s + t : (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] @@ -1676,31 +1477,14 @@ private theorem braid_coord_odd (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w, 0) : (superPow (stdSuperPair k ℓ) 2).odd) = 0 := by - refine Eq.trans (congrArg (fun t => - ((((((0 : (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] - (stdSuperPair k ℓ).even), t) : - (superPow (stdSuperPair k ℓ) 1).even) ⊗ₜ[ℂ] w), - (0 : (superPow (stdSuperPair k ℓ) 1).odd - ⊗[ℂ] (stdSuperPair k ℓ).even)) : - (superPow (stdSuperPair k ℓ) 2).odd)) - (subsingleton_tmul_eq_zero a₂)) ?_ - refine Eq.trans (congrArg (fun t => - ((t, (0 : (superPow (stdSuperPair k ℓ) 1).odd - ⊗[ℂ] (stdSuperPair k ℓ).even)) : - (superPow (stdSuperPair k ℓ) 2).odd)) - (show ((((0 : - (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] - (stdSuperPair k ℓ).even), (0 : - (superPow (stdSuperPair k ℓ) 0).odd ⊗[ℂ] - (stdSuperPair k ℓ).odd)) : - (superPow (stdSuperPair k ℓ) 1).even)) - ⊗ₜ[ℂ] w = 0 from - TensorProduct.zero_tmul _ w)) ?_ - exact Prod.ext_iff.mpr ⟨rfl, rfl⟩ + 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.induction_on with - | zero => exact hP0 + induction v₂ using TensorProduct.inductionOn with | add s t hs ht => rw [show ((0, s + t) : (superPow (stdSuperPair k ℓ) 2).odd) = @@ -1739,25 +1523,7 @@ private theorem braid_coord_odd exact Prod.ext_iff.mpr ⟨(add_zero 0).symm, rfl⟩ refine Eq.mpr (congrArg P helem) (hPadd _ _ ?_ ?_) · clear helem - induction b₁ using TensorProduct.induction_on with - | zero => - have h0elem : ((0, ((((0 : - (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] - (stdSuperPair k ℓ).odd), 0) : - (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y)) : - (superPow (stdSuperPair k ℓ) 2).odd) = 0 := by - refine Eq.trans (congrArg (fun t => - (((0 : (superPow (stdSuperPair k ℓ) 1).even - ⊗[ℂ] (stdSuperPair k ℓ).odd), t) : - (superPow (stdSuperPair k ℓ) 2).odd)) - (show ((((0 : - (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] - (stdSuperPair k ℓ).odd), 0) : - (superPow (stdSuperPair k ℓ) 1).odd)) - ⊗ₜ[ℂ] y = 0 from - TensorProduct.zero_tmul _ y)) ?_ - exact Prod.ext_iff.mpr ⟨rfl, rfl⟩ - exact Eq.mpr (congrArg P h0elem) hP0 + induction b₁ using TensorProduct.inductionOn with | add s t hs ht => have helem : ((0, ((((s + t : (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] @@ -1799,29 +1565,164 @@ private theorem braid_coord_odd (stdSuperPair k ℓ).odd), b₂) : (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y)) : (superPow (stdSuperPair k ℓ) 2).odd) = 0 := by - refine Eq.trans (congrArg (fun t => - (((0 : (superPow (stdSuperPair k ℓ) 1).even - ⊗[ℂ] (stdSuperPair k ℓ).odd), - ((((0 : (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] - (stdSuperPair k ℓ).odd), t) : - (superPow (stdSuperPair k ℓ) 1).odd) ⊗ₜ[ℂ] y)) : - (superPow (stdSuperPair k ℓ) 2).odd)) - (subsingleton_tmul_eq_zero b₂)) ?_ - refine Eq.trans (congrArg (fun t => - (((0 : (superPow (stdSuperPair k ℓ) 1).even - ⊗[ℂ] (stdSuperPair k ℓ).odd), t) : - (superPow (stdSuperPair k ℓ) 2).odd)) - (show ((((0 : - (superPow (stdSuperPair k ℓ) 0).even ⊗[ℂ] - (stdSuperPair k ℓ).odd), (0 : - (superPow (stdSuperPair k ℓ) 0).odd ⊗[ℂ] - (stdSuperPair k ℓ).even)) : - (superPow (stdSuperPair k ℓ) 1).odd)) - ⊗ₜ[ℂ] y = 0 from - TensorProduct.zero_tmul _ y)) ?_ - exact Prod.ext_iff.mpr ⟨rfl, rfl⟩ + 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 : ℕ) @@ -1831,7 +1732,7 @@ private theorem firstHalf_swapTop (n : ℕ) (⟨n, by omega⟩ : Fin (n + 2)) ⟨n + 1, by omega⟩) = MixedColouring.firstHalf (a := n) (b := 2) c := by funext i - show c (_root_.Equiv.swap + 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 ?_ ?_) @@ -1849,7 +1750,7 @@ private theorem secondHalf_swapTop (n : ℕ) _root_.Equiv.swap (⟨0, by omega⟩ : Fin 2) ⟨1, by omega⟩ := by funext j - show c (_root_.Equiv.swap + 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 @@ -1859,17 +1760,17 @@ private theorem secondHalf_swapTop (n : ℕ) interval_cases jv · rw [show Fin.natAdd n (⟨0, hj⟩ : Fin 2) = (⟨n, by omega⟩ : Fin (n + 2)) from Fin.ext (by - show n + 0 = n; omega)] + 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 show n + 1 = n + 1; rfl) + 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 show n = n + 0; omega) + exact Fin.ext (by change n = n + 0; omega) private theorem adjSign_secondHalf (n : ℕ) (c : MixedColouring k ℓ (n + 2)) : @@ -1879,7 +1780,7 @@ private theorem adjSign_secondHalf (n : ℕ) unfold adjSign rw [show MixedColouring.secondHalf (a := n) (b := 2) c ⟨0, by omega⟩ = c ⟨n, by omega⟩ from - congrArg c (Fin.ext (by show n + 0 = n; omega))] + 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)] @@ -1929,12 +1830,12 @@ private theorem braidN_coord_even (n : ℕ) ⟨c ∘ _root_.Equiv.swap (⟨n, by omega⟩ : Fin (n + 2)) ⟨n + 1, by omega⟩, hc.comp _⟩ with hP - show P w + change P w have hP0 : P 0 := by rw [hP] beta_reduce simp only [map_zero] - show (0 : ℂ) = adjSign c ⟨n, by omega⟩ + 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 @@ -1965,8 +1866,8 @@ private theorem braidN_coord_even (n : ℕ) (colourMerge_coord n 2 p q _ (hc.comp _)).symm) by_cases hfh : MixedColouring.IsEven (MixedColouring.firstHalf (a := n) (b := 2) c) - · rw [dif_pos hfh] - rw [dif_pos (show MixedColouring.IsEven + · 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)) @@ -1997,8 +1898,8 @@ private theorem braidN_coord_even (n : ℕ) Subtype.ext (secondHalf_swapTop n c)] rw [adjSign_secondHalf n c] ring - · rw [dif_neg hfh] - rw [dif_neg (show ¬ MixedColouring.IsEven + · 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)) @@ -2029,16 +1930,16 @@ private theorem braidN_coord_even (n : ℕ) (colourMerge_coord_oddPair n 2 p q _ (hc.comp _)).symm) by_cases hfh : MixedColouring.IsEven (MixedColouring.firstHalf (a := n) (b := 2) c) - · rw [dif_pos hfh] - rw [dif_pos (show MixedColouring.IsEven + · 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 [dif_neg hfh] - rw [dif_neg (show ¬ MixedColouring.IsEven + · 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)) @@ -2077,8 +1978,7 @@ private theorem braidN_coord_even (n : ℕ) (w₁, 0) + (0, w₂) from by rw [Prod.mk_add_mk, add_zero, zero_add]] refine hPadd _ _ ?_ ?_ - · induction w₁ using TensorProduct.induction_on with - | zero => exact hP0 + · induction w₁ using TensorProduct.inductionOn with | add s t hs ht => rw [show ((s + t, 0) : (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) n) @@ -2087,8 +1987,7 @@ private theorem braidN_coord_even (n : ℕ) rw [Prod.mk_add_mk, add_zero]] exact hPadd _ _ hs ht | tmul p q => exact hblock1 p q - · induction w₂ using TensorProduct.induction_on with - | zero => exact hP0 + · induction w₂ using TensorProduct.inductionOn with | add s t hs ht => rw [show ((0, s + t) : (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) n) @@ -2107,7 +2006,7 @@ private theorem tensorHom_oddFst {V₁ V₂ W₁ W₂ : SuperVect} ((v ⊗ₜ[ℂ] u, (0 : V₁.odd ⊗[ℂ] V₂.even))) = ((e₁.evenMap v ⊗ₜ[ℂ] e₂.oddMap u, (0 : W₁.odd ⊗[ℂ] W₂.even))) := by - show (TensorProduct.map e₁.evenMap e₂.oddMap (v ⊗ₜ[ℂ] u), + change (TensorProduct.map e₁.evenMap e₂.oddMap (v ⊗ₜ[ℂ] u), TensorProduct.map e₁.oddMap e₂.evenMap 0) = _ rw [TensorProduct.map_tmul, map_zero] @@ -2118,7 +2017,7 @@ private theorem tensorHom_oddSnd {V₁ V₂ W₁ W₂ : SuperVect} (((0 : V₁.even ⊗[ℂ] V₂.odd), v ⊗ₜ[ℂ] u)) = (((0 : W₁.even ⊗[ℂ] W₂.odd), e₁.oddMap v ⊗ₜ[ℂ] e₂.evenMap u)) := by - show (TensorProduct.map e₁.evenMap e₂.oddMap 0, + change (TensorProduct.map e₁.evenMap e₂.oddMap 0, TensorProduct.map e₁.oddMap e₂.evenMap (v ⊗ₜ[ℂ] u)) = _ rw [TensorProduct.map_tmul, map_zero] @@ -2175,12 +2074,12 @@ private theorem braidN_coord_odd (n : ℕ) ⟨c ∘ _root_.Equiv.swap (⟨n, by omega⟩ : Fin (n + 2)) ⟨n + 1, by omega⟩, MixedColouring.not_isEven_comp hc _⟩ with hP - show P w + change P w have hP0 : P 0 := by rw [hP] beta_reduce simp only [map_zero] - show (0 : ℂ) = adjSign c ⟨n, by omega⟩ + 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 @@ -2215,8 +2114,8 @@ private theorem braidN_coord_odd (n : ℕ) (MixedColouring.not_isEven_comp hc _)).symm) by_cases hfh : MixedColouring.IsEven (MixedColouring.firstHalf (a := n) (b := 2) c) - · rw [dif_pos hfh] - rw [dif_pos (show MixedColouring.IsEven + · 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)) @@ -2248,8 +2147,8 @@ private theorem braidN_coord_odd (n : ℕ) Subtype.ext (secondHalf_swapTop n c)] rw [adjSign_secondHalf n c] ring - · rw [dif_neg hfh] - rw [dif_neg (show ¬ MixedColouring.IsEven + · 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)) @@ -2281,16 +2180,16 @@ private theorem braidN_coord_odd (n : ℕ) (MixedColouring.not_isEven_comp hc _)).symm) by_cases hfh : MixedColouring.IsEven (MixedColouring.firstHalf (a := n) (b := 2) c) - · rw [dif_pos hfh] - rw [dif_pos (show MixedColouring.IsEven + · 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 [dif_neg hfh] - rw [dif_neg (show ¬ MixedColouring.IsEven + · 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)) @@ -2328,8 +2227,7 @@ private theorem braidN_coord_odd (n : ℕ) (w₁, 0) + (0, w₂) from by rw [Prod.mk_add_mk, add_zero, zero_add]] refine hPadd _ _ ?_ ?_ - · induction w₁ using TensorProduct.induction_on with - | zero => exact hP0 + · induction w₁ using TensorProduct.inductionOn with | add s t hs ht => rw [show ((s + t, 0) : (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) n) @@ -2338,8 +2236,7 @@ private theorem braidN_coord_odd (n : ℕ) rw [Prod.mk_add_mk, add_zero]] exact hPadd _ _ hs ht | tmul p q => exact hblock1 p q - · induction w₂ using TensorProduct.induction_on with - | zero => exact hP0 + · induction w₂ using TensorProduct.inductionOn with | add s t hs ht => rw [show ((0, s + t) : (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) n) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourExtendSwap.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourExtendSwap.lean index 5bd45d5cf8..5bccdb5aa1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourExtendSwap.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourExtendSwap.lean @@ -48,16 +48,13 @@ private theorem swap_castSucc_eq {n i : ℕ} (h : i + 2 ≤ n + 1) /-- Composition of `funTensorFun`, `TensorProduct.map f id`, for general tensor elements. -/ -private theorem funTensorFun_map_id {ι κ : Type} [Fintype ι] [DecidableEq ι] - [Fintype κ] [DecidableEq κ] +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.induction_on with - | zero => - simp only [map_zero, Pi.zero_apply] - change 0 = f 0 x; simp [map_zero] + 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 @@ -358,7 +355,7 @@ theorem colourExtend_colourSwap {k ℓ : ℕ} (n i : ℕ) SuperVect.Hom _ _).evenMap ((colourPowerStep k ℓ (n + 1)).evenEquiv P) by ext F - show (colourPowerStep k ℓ (n + 1)).evenEquiv + change (colourPowerStep k ℓ (n + 1)).evenEquiv (((SuperVect.tensorHom (colourSwap k ℓ (n + 1) i h) (SuperVect.Hom.id (stdSuperPair k ℓ)) : SuperVect.Hom _ _).evenMap) @@ -370,7 +367,7 @@ theorem colourExtend_colourSwap {k ℓ : ℕ} (n i : ℕ) intro P funext ⟨c, hc⟩ rw [step_tensorHom_even_apply] - show Sum.elim + change Sum.elim (fun p => funTensorFun _ _ (TensorProduct.map (colourSwap k ℓ (n + 1) i h : SuperVect.Hom _ _).evenMap LinearMap.id P.1) p) @@ -412,7 +409,7 @@ theorem colourExtend_colourSwap {k ℓ : ℕ} (n i : ℕ) SuperVect.Hom _ _).oddMap ((colourPowerStep k ℓ (n + 1)).oddEquiv P) by ext F - show (colourPowerStep k ℓ (n + 1)).oddEquiv + change (colourPowerStep k ℓ (n + 1)).oddEquiv (((SuperVect.tensorHom (colourSwap k ℓ (n + 1) i h) (SuperVect.Hom.id (stdSuperPair k ℓ)) : SuperVect.Hom _ _).oddMap) @@ -423,7 +420,7 @@ theorem colourExtend_colourSwap {k ℓ : ℕ} (n i : ℕ) intro P funext ⟨c, hc⟩ rw [step_tensorHom_odd_apply] - show Sum.elim + change Sum.elim (fun p => funTensorFun _ _ (TensorProduct.map (colourSwap k ℓ (n + 1) i h : SuperVect.Hom _ _).evenMap LinearMap.id P.1) p) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourFormMatch.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourFormMatch.lean index edbf38814d..2890a82059 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourFormMatch.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourFormMatch.lean @@ -30,34 +30,34 @@ 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] - show (if a.val + ℓ = b.val then (1 : ℂ) + 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 [dif_pos h, if_pos h] + · rw [dite_eq_left h, ite_eq_left h] by_cases hb : a.val + ℓ = b.val - · rw [if_pos hb, - if_pos (show b = ⟨a.val + ℓ, by omega⟩ from + · 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 [if_neg hb, - if_neg (show ¬(b.val + ℓ = a.val) by omega), - if_neg (show ¬(b = ⟨a.val + ℓ, by omega⟩) from + · 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 [dif_neg h, if_neg h, - if_neg (show ¬(a.val + ℓ = b.val) by + · 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 [if_pos hb, - if_pos (show b = ⟨a.val - ℓ, by omega⟩ from + · 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 [if_neg hb, - if_neg (show ¬(b = ⟨a.val - ℓ, by omega⟩) from + · 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))] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMerge.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMerge.lean index ea45f60373..efb5ce7162 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMerge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMerge.lean @@ -48,14 +48,14 @@ theorem MixedColouring.oddSet_card_split {k ℓ a b : ℕ} theorem MixedColouring.firstHalf_zero {k ℓ a : ℕ} (c : MixedColouring k ℓ (a + 0)) : c.firstHalf = c := by - funext i; show c (Fin.castAdd 0 i) = c i; congr 1 + 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 - show c (Fin.castAdd b i).castSucc = c (Fin.castAdd (b + 1) 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. -/ @@ -64,7 +64,7 @@ theorem MixedColouring.secondHalf_tail {k ℓ a b : ℕ} (MixedColouring.tail c).secondHalf = MixedColouring.tail (c.secondHalf) := by funext j - show c (Fin.natAdd a j).castSucc = c (Fin.natAdd a j.castSucc) + 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. -/ @@ -97,7 +97,7 @@ 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 - show c (Fin.natAdd a (Fin.last b)) = c (Fin.last (a + b)) + change c (Fin.natAdd a (Fin.last b)) = c (Fin.last (a + b)) congr 1 /-! ### Forward computation of evenSplitEquiv -/ @@ -189,7 +189,7 @@ theorem cps_even_at_inl {k ℓ d : ℕ} funTensorFun _ _ z₁ (⟨MixedColouring.tail c, (c.isEven_succ_left a' ha).mp hc⟩, a') := by - show Sum.elim (fun p => funTensorFun _ _ z₁ p) + 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] @@ -207,7 +207,7 @@ theorem cps_even_at_inr {k ℓ d : ℕ} funTensorFun _ _ z₂ (⟨MixedColouring.tail c, (c.isEven_succ_right b' hb).mp hc⟩, b') := by - show Sum.elim (fun p => funTensorFun _ _ z₁ p) + 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] @@ -257,7 +257,7 @@ theorem cps_odd_at_inl {k ℓ d : ℕ} -- 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') - show (Sum.elim (funTensorFun _ _ z₁) (funTensorFun _ _ z₂)) + 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, @@ -277,7 +277,7 @@ theorem cps_odd_at_inr {k ℓ d : ℕ} (⟨MixedColouring.tail c, Decidable.not_not.mp ((c.isEven_succ_right b' hb).not.mp hc)⟩, b') := by - show (Sum.elim (funTensorFun _ _ z₁) (funTensorFun _ _ z₂)) + 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, @@ -302,7 +302,7 @@ private theorem assoc_inv_ee_tmul {k ℓ a b : ℕ} (superPow (stdSuperPair k ℓ) b)).odd ⊗[ℂ] (stdSuperPair k ℓ).odd))) : (SuperVect.tensorObj (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b)) (stdSuperPair k ℓ)).even) := by - show (SuperVect.assocAux _ _ _ _ _ _).symm + change (SuperVect.assocAux _ _ _ _ _ _).symm ((v ⊗ₜ[ℂ] ((w₁ ⊗ₜ[ℂ] x₁, (0 : _)) : _), (0 : _)) : _) = _ exact SuperVect.assocAux_symm_ee v w₁ x₁ @@ -324,7 +324,7 @@ private theorem assoc_inv_eo_tmul {k ℓ a b : ℕ} (superPow (stdSuperPair k ℓ) b).even)) ⊗ₜ[ℂ] x₂)) : (SuperVect.tensorObj (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b)) (stdSuperPair k ℓ)).even) := by - show (SuperVect.assocAux _ _ _ _ _ _).symm + change (SuperVect.assocAux _ _ _ _ _ _).symm ((v ⊗ₜ[ℂ] (((0 : _), w₂ ⊗ₜ[ℂ] x₂) : _), (0 : _)) : _) = _ exact SuperVect.assocAux_symm_eo v w₂ x₂ @@ -353,7 +353,7 @@ private theorem assoc_inv_odd_eo_tmul {k ℓ a b : ℕ} (superPow (stdSuperPair k ℓ) b)).odd ⊗[ℂ] (stdSuperPair k ℓ).even)) : (SuperVect.tensorObj (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b)) (stdSuperPair k ℓ)).odd) := by - show (SuperVect.assocAux _ _ _ _ _ _).symm + change (SuperVect.assocAux _ _ _ _ _ _).symm ((v ⊗ₜ[ℂ] ((w₂ ⊗ₜ[ℂ] x₂, (0 : _)) : _), (0 : _)) : _) = _ exact SuperVect.assocAux_symm_ee v w₂ x₂ @@ -382,7 +382,7 @@ private theorem assoc_inv_odd_oe_tmul {k ℓ a b : ℕ} (superPow (stdSuperPair k ℓ) b).even)) ⊗ₜ[ℂ] x₁)) : (SuperVect.tensorObj (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b)) (stdSuperPair k ℓ)).odd) := by - show (SuperVect.assocAux _ _ _ _ _ _).symm + change (SuperVect.assocAux _ _ _ _ _ _).symm ((v ⊗ₜ[ℂ] (((0 : _), w₁ ⊗ₜ[ℂ] x₁) : _), (0 : _)) : _) = _ exact SuperVect.assocAux_symm_eo v w₁ x₁ @@ -413,7 +413,7 @@ private theorem chain_even_ee {k ℓ a b : ℕ} (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) ∘ α⁻¹ - show (colourPowerStep k ℓ (a + b)).evenEquiv + change (colourPowerStep k ℓ (a + b)).evenEquiv ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ (a + b)) (SuperLinearEquiv.refl (stdSuperPair k ℓ))).evenEquiv ((powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ : @@ -427,7 +427,7 @@ private theorem chain_even_ee {k ℓ a b : ℕ} LinearMap.id := rfl simp only [MonoidalCategoryStruct.whiskerRight, SuperVect.tensorHom_evenMap, hid_e] - show LinearEquiv.prodCongr + change LinearEquiv.prodCongr (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).evenEquiv (LinearEquiv.refl ℂ _)) (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).oddEquiv @@ -466,7 +466,7 @@ private theorem chain_even_eo {k ℓ a b : ℕ} (superPow (stdSuperPair k ℓ) b)).odd)) ) ⊗ₜ[ℂ] x₂)) := by -- Unfold cpe(a+(b+1)) = cps ∘ tc and pm(a,b+1) = (pm ▷ V) ∘ α⁻¹ - show (colourPowerStep k ℓ (a + b)).evenEquiv + change (colourPowerStep k ℓ (a + b)).evenEquiv ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ (a + b)) (SuperLinearEquiv.refl (stdSuperPair k ℓ))).evenEquiv ((powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ : @@ -480,7 +480,7 @@ private theorem chain_even_eo {k ℓ a b : ℕ} LinearMap.id := rfl simp only [MonoidalCategoryStruct.whiskerRight, SuperVect.tensorHom_evenMap, hid_o] - show LinearEquiv.prodCongr + change LinearEquiv.prodCongr (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).evenEquiv (LinearEquiv.refl ℂ _)) (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).oddEquiv @@ -507,7 +507,7 @@ theorem rhs_even_ee {k ℓ b : ℕ} (((colourPowerEquiv k ℓ b).evenEquiv w₁ ⊗ₜ[ℂ] x₁, (0 : ({c : MixedColouring k ℓ b // ¬ c.IsEven} → ℂ) ⊗[ℂ] (Fin (2 * ℓ) → ℂ)))) := by - show (colourPowerStep k ℓ b).evenEquiv + change (colourPowerStep k ℓ b).evenEquiv (LinearEquiv.prodCongr (TensorProduct.congr (colourPowerEquiv k ℓ b).evenEquiv (LinearEquiv.refl ℂ _)) @@ -534,7 +534,7 @@ theorem rhs_even_oo {k ℓ b : ℕ} (((0 : ({c : MixedColouring k ℓ b // c.IsEven} → ℂ) ⊗[ℂ] (Fin k → ℂ)), (colourPowerEquiv k ℓ b).oddEquiv w₂ ⊗ₜ[ℂ] x₂)) := by - show (colourPowerStep k ℓ b).evenEquiv + change (colourPowerStep k ℓ b).evenEquiv (LinearEquiv.prodCongr (TensorProduct.congr (colourPowerEquiv k ℓ b).evenEquiv (LinearEquiv.refl ℂ _)) @@ -573,7 +573,7 @@ private theorem chain_odd_eo {k ℓ a b : ℕ} (evenPair v w₂))) ⊗ₜ[ℂ] x₂, (0 : ({c : MixedColouring k ℓ (a + b) // ¬ c.IsEven} → ℂ) ⊗[ℂ] (Fin k → ℂ)))) := by - show (colourPowerStep k ℓ (a + b)).oddEquiv + change (colourPowerStep k ℓ (a + b)).oddEquiv ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ (a + b)) (SuperLinearEquiv.refl (stdSuperPair k ℓ))).oddEquiv ((powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ : @@ -599,7 +599,7 @@ private theorem chain_odd_eo {k ℓ a b : ℕ} LinearMap.id := rfl simp only [MonoidalCategoryStruct.whiskerRight, SuperVect.tensorHom_oddMap, hid_o, hid_e] - show LinearEquiv.prodCongr + change LinearEquiv.prodCongr (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).evenEquiv (LinearEquiv.refl ℂ _)) (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).oddEquiv @@ -642,7 +642,7 @@ private theorem chain_odd_oe {k ℓ a b : ℕ} (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b)).odd))) ⊗ₜ[ℂ] x₁)) := by - show (colourPowerStep k ℓ (a + b)).oddEquiv + change (colourPowerStep k ℓ (a + b)).oddEquiv ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ (a + b)) (SuperLinearEquiv.refl (stdSuperPair k ℓ))).oddEquiv ((powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ : @@ -668,7 +668,7 @@ private theorem chain_odd_oe {k ℓ a b : ℕ} LinearMap.id := rfl simp only [MonoidalCategoryStruct.whiskerRight, SuperVect.tensorHom_oddMap, hid_o, hid_e] - show LinearEquiv.prodCongr + change LinearEquiv.prodCongr (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).evenEquiv (LinearEquiv.refl ℂ _)) (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).oddEquiv @@ -695,7 +695,7 @@ theorem rhs_odd_eo {k ℓ b : ℕ} (((colourPowerEquiv k ℓ b).evenEquiv w₂ ⊗ₜ[ℂ] x₂, (0 : ({c : MixedColouring k ℓ b // ¬ c.IsEven} → ℂ) ⊗[ℂ] (Fin k → ℂ)))) := by - show (colourPowerStep k ℓ b).oddEquiv + change (colourPowerStep k ℓ b).oddEquiv (LinearEquiv.prodCongr (TensorProduct.congr (colourPowerEquiv k ℓ b).evenEquiv (LinearEquiv.refl ℂ _)) @@ -722,7 +722,7 @@ theorem rhs_odd_oe {k ℓ b : ℕ} (((0 : ({c : MixedColouring k ℓ b // c.IsEven} → ℂ) ⊗[ℂ] (Fin (2 * ℓ) → ℂ)), (colourPowerEquiv k ℓ b).oddEquiv w₁ ⊗ₜ[ℂ] x₁)) := by - show (colourPowerStep k ℓ b).oddEquiv + change (colourPowerStep k ℓ b).oddEquiv (LinearEquiv.prodCongr (TensorProduct.congr (colourPowerEquiv k ℓ b).evenEquiv (LinearEquiv.refl ℂ _)) @@ -739,6 +739,352 @@ theorem rhs_odd_oe {k ℓ b : ℕ} -- Raised budget: 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 : ℕ) @@ -786,11 +1132,11 @@ private theorem colourMerge_pair {k ℓ : ℕ} (a : ℕ) have hfe : c.firstHalf.IsEven := hfh ▸ hc have h0 : (colourPowerEquiv k ℓ 0).evenEquiv w ⟨c.secondHalf, c.secondHalf_isEven hc hfe⟩ = w' := by - show (LinearEquiv.funUnique + change (LinearEquiv.funUnique {c : MixedColouring k ℓ 0 // c.IsEven} ℂ ℂ).symm w' _ = w' rfl simp only [hpow, LinearEquiv.map_smul, - dif_pos hfe, + dite_eq_left hfe, show (⟨c.firstHalf, hfe⟩ : {c : MixedColouring k ℓ a // c.IsEven}) = ⟨c, hc⟩ from Subtype.ext hfh] @@ -804,7 +1150,7 @@ private theorem colourMerge_pair {k ℓ : ℕ} (a : ℕ) -- odd side vanishes. intro u c hc have hfe : ¬ c.firstHalf.IsEven := c.firstHalf_zero ▸ hc - simp only [dif_neg hfe] + 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 @@ -819,300 +1165,8 @@ private theorem colourMerge_pair {k ℓ : ℕ} (a : ℕ) | b + 1 => by obtain ⟨ih_even, ih_odd⟩ := colourMerge_pair a v b constructor - · -- ═══════ b + 1, EVEN COMPONENT ═══════ - 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.induction_on with - | zero => - simp only [hGoal] - erw [ep_zero, map_zero, LinearEquiv.map_zero, Pi.zero_apply] - split_ifs with h - · exact (mul_zero _).symm - · rfl - | 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.induction_on with - | zero => - simp only [hGoal] - erw [ep_zero, map_zero, LinearEquiv.map_zero, Pi.zero_apply] - split_ifs with h - · exact (mul_zero _).symm - · rfl - | 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) - · -- ═══════ b + 1, ODD COMPONENT ═══════ - 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.induction_on with - | zero => - simp only [hGoal] - erw [op_zero, map_zero, LinearEquiv.map_zero, Pi.zero_apply] - split_ifs with h - · exact (mul_zero _).symm - · rfl - | 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.induction_on with - | zero => - simp only [hGoal] - erw [op_zero, map_zero, LinearEquiv.map_zero, Pi.zero_apply] - split_ifs with h - · exact (mul_zero _).symm - · rfl - | 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) + · exact colourMerge_pair_even_step a v b ih_even ih_odd + · exact colourMerge_pair_odd_step a v b ih_even ih_odd -- Raised budget: specializing the mutual induction re-elaborates -- the paired statement. diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean index 623859d626..178a75bc0b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean @@ -68,7 +68,7 @@ private theorem assoc_inv_odd_oe_ee_tmul {k ℓ a b : ℕ} x ⊗ₜ[ℂ] w₁) ⊗ₜ[ℂ] x₁)) : (SuperVect.tensorObj (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b)) (stdSuperPair k ℓ)).odd) := by - show (SuperVect.assocAux _ _ _ _ _ _).symm + change (SuperVect.assocAux _ _ _ _ _ _).symm (((0 : _), x ⊗ₜ[ℂ] ((w₁ ⊗ₜ[ℂ] x₁, (0 : _)) : _)) : _) = _ exact SuperVect.assocAux_symm_oe x w₁ x₁ @@ -98,7 +98,7 @@ private theorem assoc_inv_odd_oe_oo_tmul {k ℓ a b : ℕ} (superPow (stdSuperPair k ℓ) b)).odd ⊗[ℂ] (stdSuperPair k ℓ).even)) : (SuperVect.tensorObj (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b)) (stdSuperPair k ℓ)).odd) := by - show (SuperVect.assocAux _ _ _ _ _ _).symm + change (SuperVect.assocAux _ _ _ _ _ _).symm (((0 : _), x ⊗ₜ[ℂ] (((0 : _), w₂ ⊗ₜ[ℂ] x₂) : _)) : _) = _ exact SuperVect.assocAux_symm_oo x w₂ x₂ @@ -129,7 +129,7 @@ private theorem assoc_inv_even_oe_eo_tmul {k ℓ a b : ℕ} x ⊗ₜ[ℂ] w₁) ⊗ₜ[ℂ] x₂)) : (SuperVect.tensorObj (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b)) (stdSuperPair k ℓ)).even) := by - show (SuperVect.assocAux _ _ _ _ _ _).symm + change (SuperVect.assocAux _ _ _ _ _ _).symm (((0 : _), x ⊗ₜ[ℂ] ((w₁ ⊗ₜ[ℂ] x₂, (0 : _)) : _)) : _) = _ exact SuperVect.assocAux_symm_oe x w₁ x₂ @@ -160,7 +160,7 @@ private theorem assoc_inv_even_oe_oe_tmul {k ℓ a b : ℕ} (superPow (stdSuperPair k ℓ) b)).odd ⊗[ℂ] (stdSuperPair k ℓ).odd)) : (SuperVect.tensorObj (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b)) (stdSuperPair k ℓ)).even) := by - show (SuperVect.assocAux _ _ _ _ _ _).symm + change (SuperVect.assocAux _ _ _ _ _ _).symm (((0 : _), x ⊗ₜ[ℂ] (((0 : _), w₂ ⊗ₜ[ℂ] x₁) : _)) : _) = _ exact SuperVect.assocAux_symm_oo x w₂ x₁ @@ -201,7 +201,7 @@ private theorem chain_odd_oe_ee {k ℓ a b : ℕ} (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b)).odd))) ⊗ₜ[ℂ] x₁)) := by - show (colourPowerStep k ℓ (a + b)).oddEquiv + change (colourPowerStep k ℓ (a + b)).oddEquiv ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ (a + b)) (SuperLinearEquiv.refl (stdSuperPair k ℓ))).oddEquiv ((powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ : @@ -227,7 +227,7 @@ private theorem chain_odd_oe_ee {k ℓ a b : ℕ} LinearMap.id := rfl simp only [MonoidalCategoryStruct.whiskerRight, SuperVect.tensorHom_oddMap, hid_o, hid_e] - show LinearEquiv.prodCongr + change LinearEquiv.prodCongr (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).evenEquiv (LinearEquiv.refl ℂ _)) (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).oddEquiv @@ -272,7 +272,7 @@ private theorem chain_odd_oe_oo {k ℓ a b : ℕ} ⊗ₜ[ℂ] x₂, (0 : ({c : MixedColouring k ℓ (a + b) // ¬ c.IsEven} → ℂ) ⊗[ℂ] (Fin k → ℂ)))) := by - show (colourPowerStep k ℓ (a + b)).oddEquiv + change (colourPowerStep k ℓ (a + b)).oddEquiv ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ (a + b)) (SuperLinearEquiv.refl (stdSuperPair k ℓ))).oddEquiv ((powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ : @@ -298,7 +298,7 @@ private theorem chain_odd_oe_oo {k ℓ a b : ℕ} LinearMap.id := rfl simp only [MonoidalCategoryStruct.whiskerRight, SuperVect.tensorHom_oddMap, hid_o, hid_e] - show LinearEquiv.prodCongr + change LinearEquiv.prodCongr (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).evenEquiv (LinearEquiv.refl ℂ _)) (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).oddEquiv @@ -342,7 +342,7 @@ private theorem chain_even_oe_eo {k ℓ a b : ℕ} (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) a) (superPow (stdSuperPair k ℓ) b)).odd))) ⊗ₜ[ℂ] x₂)) := by - show (colourPowerStep k ℓ (a + b)).evenEquiv + change (colourPowerStep k ℓ (a + b)).evenEquiv ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ (a + b)) (SuperLinearEquiv.refl (stdSuperPair k ℓ))).evenEquiv ((powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ : @@ -366,7 +366,7 @@ private theorem chain_even_oe_eo {k ℓ a b : ℕ} LinearMap.id := rfl simp only [MonoidalCategoryStruct.whiskerRight, SuperVect.tensorHom_evenMap, hid_o] - show LinearEquiv.prodCongr + change LinearEquiv.prodCongr (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).evenEquiv (LinearEquiv.refl ℂ _)) (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).oddEquiv @@ -411,7 +411,7 @@ private theorem chain_even_oe_oe {k ℓ a b : ℕ} ⊗ₜ[ℂ] x₁, (0 : ({c : MixedColouring k ℓ (a + b) // ¬ c.IsEven} → ℂ) ⊗[ℂ] (Fin (2 * ℓ) → ℂ)))) := by - show (colourPowerStep k ℓ (a + b)).evenEquiv + change (colourPowerStep k ℓ (a + b)).evenEquiv ((SuperLinearEquiv.tensorCongr (colourPowerEquiv k ℓ (a + b)) (SuperLinearEquiv.refl (stdSuperPair k ℓ))).evenEquiv ((powMerge (stdSuperPair k ℓ) a b ▷ stdSuperPair k ℓ : @@ -435,7 +435,7 @@ private theorem chain_even_oe_oe {k ℓ a b : ℕ} LinearMap.id := rfl simp only [MonoidalCategoryStruct.whiskerRight, SuperVect.tensorHom_evenMap, hid_e] - show LinearEquiv.prodCongr + change LinearEquiv.prodCongr (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).evenEquiv (LinearEquiv.refl ℂ _)) (TensorProduct.congr (colourPowerEquiv k ℓ (a + b)).oddEquiv @@ -446,6 +446,386 @@ private theorem chain_even_oe_oe {k ℓ a b : ℕ} 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) + +-- Raised budget: specializing the mutual induction re-elaborates +-- the paired statement. + private theorem colourMerge_pair_odd {k ℓ : ℕ} (a : ℕ) (x : (superPow (stdSuperPair k ℓ) a).odd) : ∀ (b : ℕ), @@ -510,11 +890,11 @@ private theorem colourMerge_pair_odd {k ℓ : ℕ} (a : ℕ) 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 - show (LinearEquiv.funUnique + change (LinearEquiv.funUnique {c : MixedColouring k ℓ 0 // c.IsEven} ℂ ℂ).symm w' _ = w' rfl simp only [hpow, LinearEquiv.map_smul, - dif_neg hfe, + dite_eq_right hfe, show (⟨c.firstHalf, hfe⟩ : {c : MixedColouring k ℓ a // ¬ c.IsEven}) = ⟨c, hc⟩ from Subtype.ext hfh] @@ -527,7 +907,7 @@ private theorem colourMerge_pair_odd {k ℓ : ℕ} (a : ℕ) -- 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 [dif_pos hfe] + 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. @@ -546,310 +926,9 @@ private theorem colourMerge_pair_odd {k ℓ : ℕ} (a : ℕ) | b + 1 => by obtain ⟨ih_odd, ih_even⟩ := colourMerge_pair_odd a x b constructor - · -- ═══════ b + 1, ODD COORDINATES ═══════ - 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.induction_on with - | zero => - simp only [hGoal] - erw [op_zero, map_zero, LinearEquiv.map_zero, Pi.zero_apply] - split_ifs with h - · rfl - · exact (mul_zero _).symm - | 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.induction_on with - | zero => - simp only [hGoal] - erw [op_zero, map_zero, LinearEquiv.map_zero, Pi.zero_apply] - split_ifs with h - · rfl - · exact (mul_zero _).symm - | 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) - · -- ═══════ b + 1, EVEN COORDINATES ═══════ - 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.induction_on with - | zero => - simp only [hGoal] - erw [op_zero, map_zero, LinearEquiv.map_zero, Pi.zero_apply] - split_ifs with h - · rfl - · exact (mul_zero _).symm - | 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.induction_on with - | zero => - simp only [hGoal] - erw [op_zero, map_zero, LinearEquiv.map_zero, Pi.zero_apply] - split_ifs with h - · rfl - · exact (mul_zero _).symm - | 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) + · 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 --- Raised budget: specializing the mutual induction re-elaborates --- the paired statement. /-- **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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairingSymm.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairingSymm.lean index 23982bef85..bb4973d01a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairingSymm.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairingSymm.lean @@ -100,10 +100,11 @@ private theorem koszulCrossings_eq_of_parity_match {k ℓ d : ℕ} /-- 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*} [DecidableEq α] [LinearOrder α] + {α : 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 @@ -121,10 +122,11 @@ private theorem card_filter_lt_eq_card_filter_gt /-- `2 * |{(i,j) ∈ S² | i < j}| = |S|² − |S|`: the strictly-ordered pairs are exactly half the off-diagonal. -/ private theorem two_mul_strictPairs {α : Type*} - [DecidableEq α] [LinearOrder α] (S : Finset α) : + [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) ∪ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourTotal.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourTotal.lean index dd07d877f3..7633be120b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourTotal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourTotal.lean @@ -74,12 +74,12 @@ theorem colourTotalEquiv_modelPermMap (colourSplit k ℓ (n + 1) v)) c = _ rw [toColour_powBraidWord, colourSplit_symm_apply] by_cases hc : c.IsEven - · rw [dif_pos hc] + · 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 [dif_neg hc] + · rw [dite_eq_right hc] change (colourSwapWord k ℓ (adjWord σ)).oddMap (fun a => v a.val) ⟨c, hc⟩ = _ erw [colourSwapWord_oddMap, wordSign_eq_oddInversions, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourWord.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourWord.lean index 8ae59ca4e2..8b6cd058fb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourWord.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourWord.lean @@ -61,16 +61,16 @@ theorem colourSwapWord_evenMap {n : ℕ} (w : List (Fin n)) F ⟨c.val ∘ wordPerm w, c.prop.comp _⟩ := by induction w generalizing c with | nil => - show F c = 1 * F ⟨c.val ∘ (1 : _root_.Equiv.Perm + 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 => - show ((colourSwap k ℓ (n + 1) i.val (by omega)) : + change ((colourSwap k ℓ (n + 1) i.val (by omega)) : SuperVect.Hom _ _).evenMap (((colourSwapWord k ℓ w) : SuperVect.Hom _ _).evenMap F) c = _ - show adjSign c.val ⟨i.val, by omega⟩ + change adjSign c.val ⟨i.val, by omega⟩ ⟨i.val + 1, by omega⟩ * (((colourSwapWord k ℓ w) : SuperVect.Hom _ _).evenMap F) @@ -78,7 +78,7 @@ theorem colourSwapWord_evenMap {n : ℕ} (w : List (Fin n)) (⟨i.val, by omega⟩ : Fin (n + 1)) ⟨i.val + 1, by omega⟩, c.prop.comp _⟩ = _ rw [ih] - show adjSign c.val ⟨i.val, by omega⟩ + 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)) @@ -87,7 +87,7 @@ theorem colourSwapWord_evenMap {n : ℕ} (w : List (Fin n)) (⟨i.val, by omega⟩ : Fin (n + 1)) ⟨i.val + 1, by omega⟩) ∘ wordPerm w, _⟩) = _ rw [← mul_assoc] - show (adjSign c.val ⟨i.val, by omega⟩ + 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)) @@ -111,7 +111,7 @@ theorem colourSwapWord_oddMap {n : ℕ} (w : List (Fin n)) MixedColouring.not_isEven_comp c.prop _⟩ := by induction w generalizing c with | nil => - show F c = 1 * F ⟨c.val ∘ (1 : _root_.Equiv.Perm + 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) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/SuperVect.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/SuperVect.lean index 90f6b675ab..aebbf16ae8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/SuperVect.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/SuperVect.lean @@ -40,7 +40,7 @@ theorem assoc_unit_ee {V : SuperVect} (r : ℂ) (x y : V.even) : (0 : V.odd ⊗[ℂ] V.odd)) : (tensorObj V V).even)), (0 : tensorUnit.odd ⊗[ℂ] (tensorObj V V).odd)) := by - show assocEvenEquiv tensorUnit V V _ = _ + change assocEvenEquiv tensorUnit V V _ = _ exact assocAux_ee r x y /-- The unit-prefixed associator on the odd-odd block. -/ @@ -54,7 +54,7 @@ theorem assoc_unit_oo {V : SuperVect} (r : ℂ) (u v : V.odd) : u ⊗ₜ[ℂ] v) : (tensorObj V V).even)), (0 : tensorUnit.odd ⊗[ℂ] (tensorObj V V).odd)) := by - show assocEvenEquiv tensorUnit V V _ = _ + change assocEvenEquiv tensorUnit V V _ = _ exact assocAux_eo r u v /-- The unit-prefixed associator on the even-odd block. -/ @@ -69,7 +69,7 @@ theorem assoc_unit_eo {V : SuperVect} (r : ℂ) (0 : V.odd ⊗[ℂ] V.even)) : (tensorObj V V).odd)), (0 : tensorUnit.odd ⊗[ℂ] (tensorObj V V).even)) := by - show assocOddEquiv tensorUnit V V _ = _ + change assocOddEquiv tensorUnit V V _ = _ exact assocAux_ee r x v /-- The unit-prefixed associator on the odd-even block. -/ @@ -84,7 +84,7 @@ theorem assoc_unit_oe {V : SuperVect} (r : ℂ) u ⊗ₜ[ℂ] y) : (tensorObj V V).odd)), (0 : tensorUnit.odd ⊗[ℂ] (tensorObj V V).even)) := by - show assocOddEquiv tensorUnit V V _ = _ + change assocOddEquiv tensorUnit V V _ = _ exact assocAux_eo r u y /-- The braiding on the even-even block. -/ @@ -92,7 +92,7 @@ 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 - show koszulBraidingEven V W _ = _ + change koszulBraidingEven V W _ = _ simp [koszulBraidingEven, koszulEvenAux] /-- The braiding on the odd-odd block: the Koszul sign. -/ @@ -100,7 +100,7 @@ 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 - show koszulBraidingEven V W _ = _ + change koszulBraidingEven V W _ = _ simp [koszulBraidingEven, koszulEvenAux] /-- The braiding on the even-odd block. -/ @@ -108,7 +108,7 @@ 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 - show koszulBraidingOdd V W _ = _ + change koszulBraidingOdd V W _ = _ simp [koszulBraidingOdd, koszulOddAux] /-- The braiding on the odd-even block. -/ @@ -116,7 +116,7 @@ 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 - show koszulBraidingOdd V W _ = _ + change koszulBraidingOdd V W _ = _ simp [koszulBraidingOdd, koszulOddAux] /-- The unit-prefixed inverse associator on the even-even @@ -132,7 +132,7 @@ theorem assoc_unit_inv_ee {V : SuperVect} (r : ℂ) ⊗ₜ[ℂ] y, (0 : ((tensorUnit.even ⊗[ℂ] V.odd) × (tensorUnit.odd ⊗[ℂ] V.even)) ⊗[ℂ] V.odd))) := by - show (assocEvenEquiv tensorUnit V V).symm _ = _ + 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. -/ @@ -147,7 +147,7 @@ theorem assoc_unit_inv_oo {V : SuperVect} (r : ℂ) (tensorUnit.odd ⊗[ℂ] V.odd)) ⊗[ℂ] V.even), (r ⊗ₜ[ℂ] u, (0 : tensorUnit.odd ⊗[ℂ] V.even)) ⊗ₜ[ℂ] v)) := by - show (assocEvenEquiv tensorUnit V V).symm _ = _ + 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. -/ @@ -162,7 +162,7 @@ theorem assoc_unit_inv_eo {V : SuperVect} (r : ℂ) ⊗ₜ[ℂ] v, (0 : ((tensorUnit.even ⊗[ℂ] V.odd) × (tensorUnit.odd ⊗[ℂ] V.even)) ⊗[ℂ] V.even))) := by - show (assocOddEquiv tensorUnit V V).symm _ = _ + 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. -/ @@ -177,7 +177,7 @@ theorem assoc_unit_inv_oe {V : SuperVect} (r : ℂ) (tensorUnit.odd ⊗[ℂ] V.odd)) ⊗[ℂ] V.odd), (r ⊗ₜ[ℂ] u, (0 : tensorUnit.odd ⊗[ℂ] V.even)) ⊗ₜ[ℂ] y)) := by - show (assocOddEquiv tensorUnit V V).symm _ = _ + change (assocOddEquiv tensorUnit V V).symm _ = _ exact (LinearEquiv.symm_apply_eq _).mpr (assocAux_eo r u y).symm end SuperVect diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/TotalSpace.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/TotalSpace.lean index b5ea4983b0..7810f57def 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/TotalSpace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/TotalSpace.lean @@ -41,7 +41,7 @@ theorem tot_comp {V W X : SuperVect} (f : V ⟶ W) (g : W ⟶ X) : theorem tot_add {V W : SuperVect} (f g : V ⟶ W) : tot (f + g) = tot f + tot g := by refine LinearMap.ext fun x => ?_ - show ((f + g).evenMap x.1, (f + g).oddMap x.2) = _ + change ((f + g).evenMap x.1, (f + g).oddMap x.2) = _ rw [SuperVect.add_evenMap, SuperVect.add_oddMap] rfl @@ -49,7 +49,7 @@ theorem tot_add {V W : SuperVect} (f g : V ⟶ W) : theorem tot_smul {V W : SuperVect} (c : ℂ) (f : V ⟶ W) : tot (c • f) = c • tot f := by refine LinearMap.ext fun x => ?_ - show ((c • f).evenMap x.1, (c • f).oddMap x.2) = _ + change ((c • f).evenMap x.1, (c • f).oddMap x.2) = _ rw [SuperVect.smul_evenMap, SuperVect.smul_oddMap] rfl diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/WordSignPerm.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/WordSignPerm.lean index 85ec7ca27a..b67840c278 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/WordSignPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/WordSignPerm.lean @@ -263,8 +263,8 @@ private theorem neg_one_pow_oddInversions_swap_mul {n : ℕ} exact absurd hgt (by simp only [gt_iff_lt, not_lt, Fin.le_def]; omega) rw [hins, Finset.card_insert_of_notMem hnotmem] - show adjSign c a b * (-1 : ℂ) ^ _ = (-1 : ℂ) ^ (_ + 1) - rw [adjSign, if_pos hbo, pow_succ] + 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 @@ -281,14 +281,14 @@ private theorem neg_one_pow_oddInversions_swap_mul {n : ℕ} exact absurd hgt (by simp only [gt_iff_lt, not_lt, Fin.le_def]; omega) rw [hins, Finset.card_insert_of_notMem hnotmem] - show adjSign c a b * (-1 : ℂ) ^ (_ + 1) = (-1 : ℂ) ^ _ - rw [adjSign, if_pos hbo, pow_succ] + 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] - show adjSign c a b * (-1 : ℂ) ^ _ = (-1 : ℂ) ^ _ - rw [adjSign, if_neg hbo, one_mul] + 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. -/ @@ -300,7 +300,7 @@ theorem wordSign_eq_oddInversions {n : ℕ} (w : List (Fin n)) | nil => simp only [wordSign, wordPerm, oddInversions_one, pow_zero] | cons i w ih => - show adjSign c ⟨i.val, by omega⟩ ⟨i.val + 1, by omega⟩ * + 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⟩) = diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantExpand.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantExpand.lean index b3a9c7e448..2be2a9ea35 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantExpand.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantExpand.lean @@ -52,7 +52,7 @@ theorem coeff_mul_alternant (P : MvPolynomial (Fin k) ℂ) ∏ i, (X i : MvPolynomial (Fin k) ℂ) ^ ((k - 1) - ((τ i : Fin k) : ℕ)) from Finset.prod_congr rfl fun i _ => by - show (X i : MvPolynomial (Fin k) ℂ) ^ + change (X i : MvPolynomial (Fin k) ℂ) ^ (0 + ((k - 1) - ((τ i : Fin k) : ℕ))) = _ rw [Nat.zero_add]] rw [prod_pow_eq_monomial, stairShift])] @@ -71,7 +71,7 @@ theorem coeff_mul_alternant (P : MvPolynomial (Fin k) ℂ) refine Finset.sum_congr rfl fun τ _ => ?_ rw [MvPolynomial.coeff_C_mul, coeff_mul_monomial'] by_cases hle : stairShift τ ≤ w₀ - · rw [if_pos hle, if_pos hle, mul_one] - · rw [if_neg hle, if_neg hle] + · 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 index 8b976ed208..e257dd46db 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantPieri.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantPieri.lean @@ -52,17 +52,17 @@ private theorem prod_update_eq (τ : Equiv.Perm (Fin k)) · subst h rw [show (τ : Fin k → Fin k) (τ.symm m) = m from Equiv.apply_symm_apply τ m] - rw [Function.update_self, if_pos rfl, pow_succ, + 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 _ _, if_neg h, one_mul] + 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 [if_pos (Finset.mem_univ _)] + rw [ite_eq_left (Finset.mem_univ _)] open scoped Classical in /-- **The Pieri rule for alternants**: multiplying by the first diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantStrict.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantStrict.lean index e49e13d1c0..f773c5fdae 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantStrict.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantStrict.lean @@ -27,7 +27,7 @@ theorem altDet_eq_zero_of_repeat (e : Fin k → ℕ) {i j : Fin k} rw [altDet] apply Matrix.det_zero_of_row_eq hij funext l - show (X l : MvPolynomial (Fin k) ℂ) ^ (e i) = X l ^ (e j) + change (X l : MvPolynomial (Fin k) ℂ) ^ (e i) = X l ^ (e j) rw [he] /-- Strictly decreasing sequences agreeing after a permutation @@ -72,13 +72,13 @@ theorem alternant_coeff_strict (e w : Fin k → ℕ) classical by_cases heq : e = w · subst heq - rw [if_pos rfl, altDet] + 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 [if_neg heq, altDet, Matrix.det_apply'] + · 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) ℂ) * @@ -97,7 +97,7 @@ theorem alternant_coeff_strict (e w : Fin k → ℕ) rw [show ((Equiv.Perm.sign τ : ℤ) : MvPolynomial (Fin k) ℂ) = MvPolynomial.C ((Equiv.Perm.sign τ : ℤ) : ℂ) from by simp, MvPolynomial.coeff_C_mul, coeff_monomial] - rw [if_neg (fun hc => ?_), mul_zero] + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/Bialternant.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/Bialternant.lean index 956ecffa0a..392faf5313 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/Bialternant.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/Bialternant.lean @@ -82,7 +82,7 @@ matrix. -/ theorem hMat_eq_submatrix (v : Fin k → ℕ) : hMat v = (jtMat v).submatrix id Fin.revPerm := by refine Matrix.ext fun i r => ?_ - show hSubZ Finset.univ + change hSubZ Finset.univ ((v i : ℤ) + ((k : ℤ) - 1 - (r : ℕ)) - (i : ℕ)) = hSubZ Finset.univ ((v i : ℤ) + ((Fin.revPerm r : Fin k) : ℕ) - (i : ℕ)) @@ -105,15 +105,15 @@ theorem det_hMat (v : Fin k → ℕ) : unit diagonal. -/ theorem det_jtMat_zero : (jtMat (fun _ : Fin k => 0)).det = 1 := by - rw [Matrix.det_of_upperTriangular] + rw [Matrix.det_of_isUpperTriangular] · refine Finset.prod_eq_one fun i _ => ?_ - show hSubZ Finset.univ + 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 - show hSubZ Finset.univ + change hSubZ Finset.univ (((0 : ℕ) : ℤ) + (j : ℕ) - (i : ℕ)) = 0 have hlt : (j : ℕ) < (i : ℕ) := hij exact hSubZ_neg _ _ (by omega) diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialDet.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialDet.lean index c37a7d91ae..1ddb376608 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialDet.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialDet.lean @@ -68,7 +68,7 @@ private theorem vandermonde_conv_trunc (s m : ℕ) (hm : s ≤ m) private theorem det_choose_upper (s : ℕ) : (Matrix.of fun t j : Fin s => (Nat.choose (j : ℕ) (t : ℕ) : ℂ)).det = 1 := by - rw [Matrix.det_of_upperTriangular (fun t j (htj : id j < id t) => 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] @@ -138,7 +138,7 @@ private theorem diagramSchur_square_const_mul (s m : ℕ) (hm : s ≤ m) rowLen_squareDiagram hi] have hpos : 0 ≤ (s : ℤ) + ((j : ℕ) : ℤ) - ((i : ℕ) : ℤ) := by omega - rw [newtonHZ, if_pos hpos] + rw [newtonHZ, ite_eq_left hpos] have harg : ((s : ℤ) + ↑↑j - ↑↑i).toNat = s + (j : ℕ) - (i : ℕ) := by omega rw [harg, newtonH_const] diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffExtract.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffExtract.lean index b422f66e0f..65c8f527c4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffExtract.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffExtract.lean @@ -70,7 +70,7 @@ theorem alternant_coeff (e : Fin k → ℕ) rw [map_one] exact Int.cast_one] rw [one_mul, coeff_monomial] - rw [if_pos (Finset.sum_congr rfl fun i _ => by + 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 @@ -82,7 +82,7 @@ theorem alternant_coeff (e : Fin k → ℕ) 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, if_neg hne, + 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 index 6c50bd901a..17a6012b1e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffSplit.lean @@ -56,7 +56,7 @@ theorem coeff_mul_split (P Q : MvPolynomial (Fin k) ℂ) have := hn a omega · intro a - show p.2 a ≤ α a + change p.2 a ≤ α a have := hpt a omega · -- backward membership @@ -80,18 +80,18 @@ theorem coeff_mul_split (P Q : MvPolynomial (Fin k) ℂ) rw [Finsupp.add_apply, sum_single_apply] at h1 exact h1 refine Prod.ext ?_ ?_ - · show (∑ a, Finsupp.single a (α a - p.2 a)) = p.1 + · change (∑ a, Finsupp.single a (α a - p.2 a)) = p.1 ext a rw [sum_single_apply] have := hpt a omega - · show (∑ a, Finsupp.single a (p.2 a)) = p.2 + · change (∑ a, Finsupp.single a (p.2 a)) = p.2 ext a rw [sum_single_apply] · -- right inverse intro w hw funext a - show (∑ b, Finsupp.single b (w b)) a = w a + change (∑ b, Finsupp.single b (w b)) a = w a rw [sum_single_apply] · -- value transfer intro p hp @@ -105,7 +105,7 @@ theorem coeff_mul_split (P Q : MvPolynomial (Fin k) ℂ) · congr 1 ext a rw [sum_single_apply] - show p.1 a = α a - p.2 a + change p.1 a = α a - p.2 a have := hpt a omega · congr 1 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/DeltaSeq.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DeltaSeq.lean index 29de571a81..bca2ce1d06 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/DeltaSeq.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DeltaSeq.lean @@ -27,7 +27,7 @@ noncomputable def deltaSeq : ℕ → ℂ := /-- The delta sequence's first value is `1`. -/ @[simp] theorem deltaSeq_one : deltaSeq 1 = 1 := by - rw [deltaSeq, if_pos rfl] + rw [deltaSeq, ite_eq_left rfl] /-- Complete homogeneous values of the delta sequence are inverse factorials. -/ @@ -41,7 +41,7 @@ theorem newtonH_deltaSeq (d : ℕ) : rw [Finset.sum_eq_single 0 (fun i _ hi => by rw [show deltaSeq (i + 1) = 0 from by - rw [deltaSeq, if_neg (by omega)]] + 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 @@ -58,9 +58,9 @@ 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 [if_pos hπ, hπ, Equiv.Perm.cycleType_one, + · rw [ite_eq_left hπ, hπ, Equiv.Perm.cycleType_one, Multiset.map_zero, Multiset.prod_zero] - · rw [if_neg hπ] + · rw [ite_eq_right hπ] have hne : π.cycleType ≠ 0 := by intro hc exact hπ (Equiv.Perm.cycleType_eq_zero.mp hc) @@ -68,7 +68,7 @@ theorem cycleProd_deltaSeq {n : ℕ} (π : Equiv.Perm (Fin n)) : refine Multiset.prod_eq_zero ?_ rw [Multiset.mem_map] refine ⟨c, hc, ?_⟩ - rw [deltaSeq, if_neg] + rw [deltaSeq, ite_eq_right] have := Equiv.Perm.two_le_of_mem_cycleType hc omega @@ -81,9 +81,9 @@ theorem jtChar_one_eq (μ : YoungDiagram) : rw [Finset.sum_congr rfl (fun π (_ : π ∈ Finset.univ) => by rw [cycleProd_deltaSeq π])] at h rw [Finset.sum_eq_single 1 - (fun π _ hπ => by rw [if_neg hπ, mul_zero]) + (fun π _ hπ => by rw [ite_eq_right hπ, mul_zero]) (fun hmem => absurd (Finset.mem_univ _) hmem)] at h - rw [if_pos rfl, mul_one] 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/DimFormula.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DimFormula.lean index d05657c9ca..18c8690302 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/DimFormula.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DimFormula.lean @@ -60,7 +60,7 @@ theorem diagramSchur_delta_mul (μ : YoungDiagram) : have hle : (k - 1) - (j : ℕ) ≤ eStair μ i := by rw [hE] omega - rw [newtonHZ, if_pos hpos, harg, newtonH_deltaSeq] + 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 @@ -72,7 +72,7 @@ theorem diagramSchur_delta_mul (μ : YoungDiagram) : exact_mod_cast Nat.factorial_ne_zero _ rw [← div_eq_mul_inv, div_eq_iff hne] linear_combination -hcast - · rw [newtonHZ, if_neg hpos, mul_zero] + · rw [newtonHZ, ite_eq_right hpos, mul_zero] have hlt : eStair μ i < (k - 1) - (j : ℕ) := by rw [hE] omega diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HInsert.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HInsert.lean index cfc2f6e9d2..014e95ffc7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HInsert.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HInsert.lean @@ -25,7 +25,7 @@ theorem hSub_insert {k : ℕ} {A : Finset (Fin k)} {j : Fin k} classical -- Rewrite all three hSub into explicit filtered sums over Sym, keeping -- the Sym type explicit to prevent Sym/Subtype transparency issues. - show ∑ w ∈ Finset.univ.filter + 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 @@ -101,7 +101,7 @@ theorem hSub_insert {k : ℕ} {A : Finset (Fin k)} {j : Fin k} -- 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 - show (w.1.map X).prod = X jj * ((w.1.erase jj).map X).prod + 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]) diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HProdCoeff.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HProdCoeff.lean index ba9172567a..6134248416 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HProdCoeff.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HProdCoeff.lean @@ -33,7 +33,7 @@ private theorem map_X_prod_eq_monomial (s : Multiset (Fin k)) : rw [Multiset.map_cons, Multiset.prod_cons, ih] rw [show (X a : MvPolynomial (Fin k) ℂ) = monomial (Finsupp.single a 1) 1 from rfl] - rw [monomial_mul, one_mul] + rw [MvPolynomial.monomial_mul_monomial, one_mul] congr 1 rw [← Multiset.singleton_add] rw [Multiset.toFinsupp_add, Multiset.toFinsupp_singleton] diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HSubZ.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HSubZ.lean index bd3011196e..4accf9b297 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HSubZ.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HSubZ.lean @@ -30,13 +30,13 @@ noncomputable def hSubZ (A : Finset (Fin k)) (d : ℤ) : @[simp] theorem hSubZ_natCast (A : Finset (Fin k)) (m : ℕ) : hSubZ A (m : ℤ) = hSub A m := by - rw [hSubZ, if_pos (Int.natCast_nonneg m), Int.toNat_natCast] + 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, if_neg (not_le.mpr hd)] + 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` diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTDetExpand.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTDetExpand.lean index b863203570..d90256cb43 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTDetExpand.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTDetExpand.lean @@ -44,13 +44,13 @@ theorem jt_term_guard (v : Fin k → ℕ) (σ : Equiv.Perm (Fin k)) : classical by_cases hp : ∀ i : Fin k, 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) - · rw [if_pos hp] + · 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 [if_neg hp] + · rw [ite_eq_right hp] rw [not_forall] at hp obtain ⟨i0, hi0⟩ := hp exact Finset.prod_eq_zero (Finset.mem_univ i0) @@ -79,8 +79,8 @@ theorem coeff_det_jtMat (v : Fin k → ℕ) (w : Fin k →₀ ℕ) : MvPolynomial.coeff_C_mul] by_cases hp : ∀ i : Fin k, 0 ≤ (v i : ℤ) + ((σ i : Fin k) : ℕ) - (i : ℕ) - · rw [if_pos hp, if_pos hp] - · rw [if_neg hp, if_neg hp, AddMonoidAlgebra.coeff_zero] + · 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/LGVStrict.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/LGVStrict.lean index a6d0d4ad96..84eeb931ba 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/LGVStrict.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/LGVStrict.lean @@ -22,7 +22,7 @@ noncrossing tuples all have `σ = 1` and count with sign `+1`, and at least one exists. -/ -open scoped Classical + namespace RS @@ -91,7 +91,7 @@ theorem diagramSchur_neg_eq_sign_mul_binomDet (s m : ℕ) (hs : 1 ≤ s) 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, if_pos (show (0 : ℤ) ≤ (s : ℤ) + ↑↑j - ↑↑i by omega)] + 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 @@ -213,11 +213,13 @@ private def partnerSet {s m : ℕ} (F : Fin s → Finset (Fin m)) 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 @@ -269,7 +271,7 @@ private def swapFam {s m : ℕ} (F : Fin s → Finset (Fin m)) (h : ℕ) 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, if_neg hj, if_neg hj'] + 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)) @@ -291,9 +293,9 @@ private theorem swapFam_prefix {s m : ℕ} (F : Fin s → Finset (Fin m)) Finset.filter_congr (fun a _ => by constructor <;> intro <;> omega) rw [h1, h2, Finset.union_empty] by_cases hji : j = i - · subst hji; rw [swapFam, if_pos rfl]; exact key _ _ + · subst hji; rw [swapFam, ite_eq_left rfl]; exact key _ _ · by_cases hji' : j = i' - · subst hji'; rw [swapFam, if_neg hji, if_pos rfl]; exact key _ _ + · 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)) @@ -308,7 +310,7 @@ private theorem swapFam_card_left {s m : ℕ} (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, if_pos rfl, + 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))] @@ -322,7 +324,7 @@ private theorem swapFam_card_right {s m : ℕ} (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, if_neg (Ne.symm hne), if_pos rfl, + 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))] @@ -364,24 +366,25 @@ private theorem swapFam_involutive {s m : ℕ} 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, if_pos rfl] + 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, if_neg (Ne.symm hne), if_pos rfl] + rw [swapFam, ite_eq_right (Ne.symm hne), ite_eq_left rfl] by_cases hji : j = i · rw [hji] - rw [swapFam, if_pos rfl] + 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, if_neg (Ne.symm hne), if_pos rfl] + 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. -/ @@ -657,6 +660,7 @@ private theorem det_eq_signed_count (s m : ℕ) : 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 @@ -717,6 +721,7 @@ private theorem const_fam_noncross {s m : ℕ} (S : Finset (Fin m)) : 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 @@ -732,6 +737,7 @@ private theorem sum_noncrossing_pos (s m : ℕ) (_ : s ≤ m) : 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 @@ -754,6 +760,7 @@ private theorem noncross_witness (s m : ℕ) (hm : s ≤ m) : /-! ## 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 => diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/PieriChain.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PieriChain.lean index fac8a56dd7..550e4eb48f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/PieriChain.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PieriChain.lean @@ -107,7 +107,7 @@ theorem coeff_chain_pos {k : ℕ} (lam mu : YoungDiagram) subst heq rw [pow_zero, one_mul, alternant_coeff_strict _ _ (eVec_strict _ _) (eVec_strict _ _), - if_pos rfl] + ite_eq_left rfl] exact ⟨1, by omega, Nat.cast_one.symm⟩ | succ r ih => -- Intermediate diagram @@ -119,7 +119,7 @@ theorem coeff_chain_pos {k : ℕ} (lam mu : YoungDiagram) -- i₀ < k have hi₀_mem : (i₀, 0) ∈ nu := by rw [YoungDiagram.mem_iff_lt_rowLen] - have := hrowLen i₀; rw [if_pos rfl] at this + 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 := diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/RationalityFromRecurrence.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RationalityFromRecurrence.lean index 7b97234c82..0ea17f205b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/RationalityFromRecurrence.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RationalityFromRecurrence.lean @@ -303,7 +303,7 @@ theorem truncated_product_from_recurrence {t : ℕ → ℂ} {a b : ℕ} 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 [dif_pos (show a - k < a + 1 by omega)] + rw [dite_eq_left (show a - k < a + 1 by omega)] congr 2 omega rw [Finset.sum_range_reflect f (a + 1), @@ -314,12 +314,11 @@ theorem truncated_product_from_recurrence {t : ℕ → ℂ} {a b : ℕ} apply Finset.sum_congr rfl intro i _ dsimp only [f] - rw [dif_pos i.isLt] + 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 @@ -340,7 +339,7 @@ theorem truncated_product_from_recurrence {t : ℕ → ℂ} {a b : ℕ} ≤ i := Polynomial.natDegree_C_mul_X_pow_le _ _ _ ≤ a := by rw [Finset.mem_range] at hi; omega have hP_deg : P.natDegree ≤ b := by - show (PowerSeries.trunc (b + 1) ((↑Q : ℂ⟦X⟧) * H)).natDegree ≤ b + 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⟩ @@ -386,7 +385,7 @@ theorem coprime_pair_from_product {t : ℕ → ℂ} -- 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. - letI := EuclideanDomain.gcdMonoid ℂ[X] + 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 @@ -479,7 +478,8 @@ theorem superPowerSums_of_recurrence {t : ℕ → ℂ} {a b : ℕ} 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) + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/RecurrenceFromVanishing.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RecurrenceFromVanishing.lean index 374ffc4134..e756766966 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/RecurrenceFromVanishing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RecurrenceFromVanishing.lean @@ -53,7 +53,7 @@ private lemma strictAnti_drop {n : ℕ} {ρ : Fin n → ℤ} have h_step := hρ (show (⟨m + d, hmd'⟩ : Fin n) < ⟨m + d + 1, hmd⟩ by exact Fin.mk_lt_mk.mpr (by omega)) - show ρ ⟨m + d + 1, hmd⟩ + ((d + 1 : ℕ) : ℤ) ≤ ρ ⟨m, hm⟩ + change ρ ⟨m + d + 1, hmd⟩ + ((d + 1 : ℕ) : ℤ) ≤ ρ ⟨m, hm⟩ omega /-- For a `StrictAnti` function `ρ` on `Fin n` valued in `ℤ`, the sum @@ -62,12 +62,12 @@ 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 - show ρ j + (j.val : ℤ) ≤ ρ i + (i.val : ℤ) + 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; show i.val + (j.val - i.val) = j.val; omega + 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⟩ + @@ -115,7 +115,7 @@ private lemma det_vanishing_of_strictAnti {t : ℕ → ℂ} {a b : ℕ} have := hf_cast i omega have hw_last : b + 1 ≤ w.getD a 0 := by - show b + 1 ≤ (List.ofFn f).getD a 0 + 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) @@ -188,7 +188,7 @@ private lemma det_vanishing_of_all_ge {t : ℕ → ℂ} {a b : ℕ} (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] - show newtonHZ t (ρ i + 1 + (j : ℤ)) = + change newtonHZ t (ρ i + 1 + (j : ℤ)) = newtonHZ t (g (σ_fun i) + 1 + (j : ℤ)) rw [hσ] rw [h_eq, det_permute, mul_eq_zero, @@ -230,7 +230,7 @@ theorem exists_recurrence_of_schurDet_vanishing {t : ℕ → ℂ} {a b : ℕ} (v '' {ρ | (b : ℤ) - a ≤ ρ}) have hspanB : span ℂ B = ⊤ := hspan.trans h_top have hBfin : B.Finite := hLI.set_finite_of_isNoetherian - haveI : Fintype B := hBfin.fintype + 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 ℂ] diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/SubsetEH.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/SubsetEH.lean index aaf70c3f82..427420e69b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/SubsetEH.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/SubsetEH.lean @@ -50,7 +50,7 @@ theorem hSub_zero (A : Finset (Fin k)) : hSub A 0 = 1 := by 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))] - letI : Unique (Sym (Fin k) 0) := + 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] @@ -85,7 +85,7 @@ theorem eSub_insert {A : Finset (Fin k)} {j : Fin k} (hj : j ∉ A) (Multiset.powersetCard r (A.val.map X)).map (fun t => X j * t.prod) from Multiset.map_congr rfl (fun t _ => by - show (X j ::ₘ t).prod = X j * t.prod + change (X j ::ₘ t).prod = X j * t.prod rw [Multiset.prod_cons])] exact Multiset.sum_map_mul_left diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/SuperPowerSums.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/SuperPowerSums.lean index dff6545159..f70386bb95 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/SuperPowerSums.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/SuperPowerSums.lean @@ -201,7 +201,7 @@ theorem powerSums_zero_of_eventually_zero 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 - show ∑ i : Fin n, c (γ i) * γ i ^ m = 0 + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/TCount.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/TCount.lean index f6e13d2a2a..b6e584c943 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/TCount.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/TCount.lean @@ -44,11 +44,11 @@ theorem t_count (v : Fin k → ℕ) refine Finset.sum_congr rfl fun τ _ => ?_ by_cases hτ : stairShift τ ≤ diagExp v · have hτ' := (stair_guard_iff v τ).mp hτ - rw [if_pos hτ, Finset.mul_sum] + 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 [if_pos ⟨hσ, hτ'⟩, if_pos hσ, coeff_hSub_prod] + · 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) : ℕ) - @@ -66,11 +66,11 @@ theorem t_count (v : Fin k → ℕ) forall_congr' fun j => by rw [stair_margin_eq v τ hτ j])] ring - · rw [if_neg (fun hc => hσ hc.1), if_neg hσ] + · rw [ite_eq_right (fun hc => hσ hc.1), ite_eq_right hσ] ring - · rw [if_neg hτ, mul_zero] + · rw [ite_eq_right hτ, mul_zero] rw [Finset.sum_eq_zero fun σ _ => by - rw [if_neg (fun hc => + 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 index 4001800dc7..e697a74049 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/TIdentity.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/TIdentity.lean @@ -53,7 +53,7 @@ theorem t_identity (v : Fin k → ℕ) rw [← h2] refine Finset.sum_congr rfl fun τ _ => ?_ by_cases hle : stairShift τ ≤ diagExp v - · rw [if_pos hle, if_pos hle, coeff_det_jtMat] - · rw [if_neg hle, if_neg hle] + · 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 index dc8d3457cd..58258b93fe 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaExp.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaExp.lean @@ -26,7 +26,7 @@ noncomputable def psLog (t : ℕ → ℂ) : PowerSeries ℂ := /-- The log series has no constant term. -/ theorem constantCoeff_psLog (t : ℕ → ℂ) : constantCoeff (psLog t) = 0 := by - rw [← coeff_zero_eq_constantCoeff, psLog, coeff_mk, if_pos rfl] + 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) := @@ -37,7 +37,7 @@ series. -/ theorem derivative_psLog (t : ℕ → ℂ) : (PowerSeries.derivative (R := ℂ)) (psLog t) = powerSumSeries t := by ext n - rw [coeff_derivative, psLog, coeff_mk, if_neg (by omega)] + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaSeries.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaSeries.lean index 2b18038699..c9eb1a7ed5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaSeries.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaSeries.lean @@ -45,8 +45,10 @@ theorem powerSeries_ode_unique {F G S : PowerSeries ℂ} 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 + 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 = diff --git a/LeanPool/RegtsSevenster/RS/Common/DiagramChain.lean b/LeanPool/RegtsSevenster/RS/Common/DiagramChain.lean index 85f193270a..4d3a64009c 100644 --- a/LeanPool/RegtsSevenster/RS/Common/DiagramChain.lean +++ b/LeanPool/RegtsSevenster/RS/Common/DiagramChain.lean @@ -62,7 +62,7 @@ theorem exists_intermediate_diagram {lam mu : YoungDiagram} exact Or.inr (lam.isLowerSet hba hlam_a) · -- lam ≤ nu: lam.cells ⊆ insert c lam.cells intro x hx - show x ∈ (insert c lam.cells : Finset _) + 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 @@ -71,7 +71,7 @@ theorem exists_intermediate_diagram {lam mu : YoungDiagram} · exact hc_mu · exact hle hlam · -- nu.card = lam.card + 1 - show (insert c lam.cells).card = lam.cells.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/MathlibDeps.lean b/LeanPool/RegtsSevenster/RS/Common/MathlibDeps.lean index 228ca8103c..0d85e294e2 100644 --- a/LeanPool/RegtsSevenster/RS/Common/MathlibDeps.lean +++ b/LeanPool/RegtsSevenster/RS/Common/MathlibDeps.lean @@ -58,7 +58,7 @@ import Mathlib.CategoryTheory.Subobject.Lattice import Mathlib.CategoryTheory.Subobject.Limits import Mathlib.Combinatorics.Enumerative.Partition.Basic import Mathlib.Combinatorics.Young.YoungDiagram -import Mathlib.Data.Complex.Basic +import Mathlib.Basic.Complex.Basic import Mathlib.Data.Fin.Embedding import Mathlib.Data.Fin.Tuple.Sort import Mathlib.Data.Finset.Card diff --git a/LeanPool/RegtsSevenster/RS/Common/PermCongr.lean b/LeanPool/RegtsSevenster/RS/Common/PermCongr.lean index 95afef582e..acd04a17f1 100644 --- a/LeanPool/RegtsSevenster/RS/Common/PermCongr.lean +++ b/LeanPool/RegtsSevenster/RS/Common/PermCongr.lean @@ -25,8 +25,7 @@ namespace RS open Equiv Equiv.Perm /-- `permCongr` is `extendDomain` along the trivial subtype. -/ -theorem permCongr_eq_extendDomain {α β : Type} [Fintype α] - [DecidableEq α] [Fintype β] [DecidableEq β] +theorem permCongr_eq_extendDomain {α β : Type} (e : α ≃ β) (π : Equiv.Perm α) : e.permCongr π = π.extendDomain @@ -56,8 +55,7 @@ noncomputable def fixedPointsPermCongrEquiv {α β : Type} 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} [Fintype α] - [DecidableEq α] [Fintype β] [DecidableEq β] +theorem card_fixedPoints_permCongr {α β : Type} (e : α ≃ β) (π : Equiv.Perm α) [Fintype (Function.fixedPoints π)] [Fintype (Function.fixedPoints (e.permCongr π))] : @@ -90,12 +88,12 @@ theorem cycleType_sumCongr_left {α β : Type} rw [hsuff, cycleType_extendDomain] ext x; rcases x with a | b · -- inl a: both sides give inl (σ a) - show Sum.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 - show Sum.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] @@ -103,7 +101,7 @@ theorem cycleType_sumCongr_left {α β : Type} /-- `sumCongr 1 τ` equals the permCongr-transport of `sumCongr τ 1` by `sumComm`. -/ theorem sumCongr_right_eq_permCongr {α β : Type} - [DecidableEq α] [DecidableEq β] (τ : Perm β) : + (τ : Perm β) : Equiv.sumCongr (1 : Perm α) τ = (Equiv.sumComm β α).permCongr (Equiv.sumCongr τ (1 : Perm α)) := by ext x @@ -118,7 +116,6 @@ theorem cycleType_sumCongr_right {α β : Type} /-- The factors `sumCongr σ 1` and `sumCongr 1 τ` are disjoint. -/ theorem disjoint_sumCongr {α β : Type} - [DecidableEq α] [DecidableEq β] (σ : Perm α) (τ : Perm β) : Disjoint (Equiv.sumCongr σ (1 : Perm β)) diff --git a/LeanPool/RegtsSevenster/RS/Common/PermTopSplit.lean b/LeanPool/RegtsSevenster/RS/Common/PermTopSplit.lean index 50f1bd7d13..031d39f5eb 100644 --- a/LeanPool/RegtsSevenster/RS/Common/PermTopSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Common/PermTopSplit.lean @@ -113,7 +113,7 @@ slot's image alone. -/ @[simp] theorem topImage_mul_extPerm (σ : Perm (Fin (n + 1))) (τ : Perm (Fin n)) : topImage (σ * extPerm τ) = topImage σ := by - show σ (extPerm τ (Fin.last n)) = σ (Fin.last n) + change σ (extPerm τ (Fin.last n)) = σ (Fin.last n) rw [extPerm_last] /-- **Precomposing with a permutation of the lower slots** acts on @@ -125,7 +125,7 @@ theorem restPerm_mul_extPerm (σ : Perm (Fin (n + 1))) (τ : Perm (Fin n)) : have h1 := succAbove_restPerm (σ * extPerm τ) j rw [topImage_mul_extPerm] at h1 have h2 : (σ * extPerm τ) j.castSucc = σ (τ j).castSucc := by - show σ (extPerm τ j.castSucc) = σ (τ j).castSucc + 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) @@ -203,7 +203,7 @@ noncomputable def ofSplit (p : Fin (n + 1)) (τ : Perm (Fin n)) : @[simp] theorem ofSplit_last (p : Fin (n + 1)) (τ : Perm (Fin n)) : ofSplit p τ (Fin.last n) = p := by - show (finSuccEquiv' p).symm ((Equiv.optionCongr τ) + change (finSuccEquiv' p).symm ((Equiv.optionCongr τ) ((finSuccEquiv' (Fin.last n)) (Fin.last n))) = p rw [finSuccEquiv'_at] simp @@ -213,7 +213,7 @@ 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 - show (finSuccEquiv' p).symm ((Equiv.optionCongr τ) + change (finSuccEquiv' p).symm ((Equiv.optionCongr τ) ((finSuccEquiv' (Fin.last n)) j.castSucc)) = p.succAbove (τ j) rw [finSuccEquiv'_last_apply_castSucc] simp @@ -259,7 +259,7 @@ theorem topCycle_zero : ofSplit_last 0 1, finRotate_last] | cast j => have h : topCycle (0 : Fin (n + 1)) j.castSucc = j.succ := by - show ofSplit (0 : Fin (n + 1)) 1 j.castSucc = j.succ + 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] @@ -360,7 +360,7 @@ 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 - show σ (topSwap (Fin.last (n + 1))) = _ + change σ (topSwap (Fin.last (n + 1))) = _ rw [topSwap_last, ← succAbove_restPerm σ (Fin.last n)] rfl @@ -373,7 +373,7 @@ theorem succAbove_topImage_restPerm_mul_topSwap (σ : Perm (Fin (n + 2))) : rw [show restPerm (σ * topSwap) (Fin.last n) = topImage (restPerm (σ * topSwap)) from rfl] at h rw [h] - show σ (topSwap (Fin.castSucc (Fin.last n))) = σ (Fin.last (n + 1)) + 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 diff --git a/LeanPool/RegtsSevenster/RS/Common/RowLenChain.lean b/LeanPool/RegtsSevenster/RS/Common/RowLenChain.lean index 8932abcf02..2c9c4920a1 100644 --- a/LeanPool/RegtsSevenster/RS/Common/RowLenChain.lean +++ b/LeanPool/RegtsSevenster/RS/Common/RowLenChain.lean @@ -74,7 +74,7 @@ theorem rowLen_of_card_succ {lam nu : YoungDiagram} rcases this with heq | hmem · exact absurd (congrArg Prod.snd heq) hne · exact (YoungDiagram.mem_cells _).mp hmem - rw [if_pos rfl] + 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 @@ -88,7 +88,7 @@ theorem rowLen_of_card_succ {lam nu : YoungDiagram} · have := hup (c.2 - 1) (by omega) (by omega) omega omega - · rw [if_neg hi] + · rw [ite_eq_right hi] apply le_antisymm · by_contra h have hmem : (i, lam.rowLen i) ∈ nu := by diff --git a/LeanPool/RegtsSevenster/RS/Common/RowSpanRank.lean b/LeanPool/RegtsSevenster/RS/Common/RowSpanRank.lean index 7d9c6afefa..79cd1dbc15 100644 --- a/LeanPool/RegtsSevenster/RS/Common/RowSpanRank.lean +++ b/LeanPool/RegtsSevenster/RS/Common/RowSpanRank.lean @@ -70,7 +70,7 @@ private theorem separating_aux [Field K] {κ : Type*} 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 - haveI : FiniteDimensional K U' := + 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 := @@ -159,7 +159,7 @@ private theorem card_le_of_independent_in_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 - haveI : FiniteDimensional K U := + 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) diff --git a/LeanPool/RegtsSevenster/RS/Common/TraceSeparation.lean b/LeanPool/RegtsSevenster/RS/Common/TraceSeparation.lean index 2fd592da80..2f5217a6ef 100644 --- a/LeanPool/RegtsSevenster/RS/Common/TraceSeparation.lean +++ b/LeanPool/RegtsSevenster/RS/Common/TraceSeparation.lean @@ -31,11 +31,11 @@ theorem linearIndependent_of_group_trace {G A : Type*} [Group G] apply LinearIndependent.of_pairwise_dual_eq_zero_one _ dual · intro σ π hne change c⁻¹ * τ (ρ σ⁻¹ * ρ π) = 0 - rw [← map_mul, hτ, if_neg (fun h => hne (inv_mul_eq_one.mp h)), + 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τ, if_pos rfl, inv_mul_cancel₀ hc] + 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Definitions.lean b/LeanPool/RegtsSevenster/RS/Definitions.lean index b5dfd49b0b..869518a448 100644 --- a/LeanPool/RegtsSevenster/RS/Definitions.lean +++ b/LeanPool/RegtsSevenster/RS/Definitions.lean @@ -178,7 +178,7 @@ def disjUnion (W₁ : Fragment α) (W₂ : Fragment β) : | inl ℓ₁ => cases f with | inl g => - rcases ha : W₁.attach g with v | ℓ' <;> simp [ha] at h + rcases ha : W₁.attach g with v | ℓ' <;> simp? [ha] at h subst h simp [W₁.eq_boundaryFlag ℓ' g ha] | inr g => @@ -188,7 +188,7 @@ def disjUnion (W₁ : Fragment α) (W₂ : Fragment β) : | inl g => rcases ha : W₁.attach g with v | ℓ' <;> simp [ha] at h | inr g => - rcases ha : W₂.attach g with v | ℓ' <;> simp [ha] at h + rcases ha : W₂.attach g with v | ℓ' <;> simp? [ha] at h subst h simp [W₂.eq_boundaryFlag ℓ' g ha] circles := W₁.circles + W₂.circles @@ -279,24 +279,24 @@ theorem rewire_invol (hij : i ≠ j) · -- 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 [dif_neg (by + rw [dite_eq_right (by rw [W.pairing_invol] exact fun h => hbne h.symm)] - rw [dif_pos (by rw [W.pairing_invol])] + 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 [dif_pos (by rw [W.pairing_invol])] + 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 [dif_neg (by rw [W.pairing_invol]; exact fun h => f.prop.1 h)] - rw [dif_neg (by rw [W.pairing_invol]; exact fun h => f.prop.2 h)] + 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 @@ -790,6 +790,7 @@ structure EdgeSubset.TransitionSystem.Orientation {α : Type} 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) @@ -857,8 +858,8 @@ noncomputable def EdgeSubset.evenColoursAt (F : EdgeSubset W) {k : ℕ} 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 - letI := W.flagOrder - letI := Classical.dec + let := W.flagOrder + let := Classical.dec unfold EdgeSubset.inFlagsAt at hf exact (Finset.mem_filter.mp ((Finset.mem_sort _).mp hf)).1 @@ -1978,7 +1979,7 @@ instance instMonoidalCategory : MonoidalCategory SuperVect := (id_tensorHom := fun _ {_ _} _ => rfl) (tensorHom_id := fun {_ _} _ _ => rfl) (tensorHom_comp_tensorHom := fun {_ _ _ _ _ _} f₁ f₂ g₁ g₂ => by - show Hom.comp (SuperVect.tensorHom g₁ g₂) (SuperVect.tensorHom f₁ f₂) = + 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 ═══════ @@ -2037,8 +2038,7 @@ instance instMonoidalCategory : MonoidalCategory SuperVect := simp only [LinearMap.comp_apply, LinearMap.fst_apply, LinearMap.prodMap_apply, LinearEquiv.coe_toLinearMap] - induction x using TensorProduct.induction_on with - | zero => simp + 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₂] @@ -2053,8 +2053,7 @@ instance instMonoidalCategory : MonoidalCategory SuperVect := simp only [LinearMap.comp_apply, LinearMap.fst_apply, LinearMap.prodMap_apply, LinearEquiv.coe_toLinearMap] - induction x using TensorProduct.induction_on with - | zero => simp + 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₂]) @@ -2074,8 +2073,7 @@ instance instMonoidalCategory : MonoidalCategory SuperVect := simp only [LinearMap.comp_apply, LinearMap.fst_apply, LinearMap.prodMap_apply, LinearEquiv.coe_toLinearMap] - induction x using TensorProduct.induction_on with - | zero => simp + 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₂] @@ -2091,8 +2089,7 @@ instance instMonoidalCategory : MonoidalCategory SuperVect := simp only [LinearMap.comp_apply, LinearMap.snd_apply, LinearMap.prodMap_apply, LinearEquiv.coe_toLinearMap] - induction y using TensorProduct.induction_on with - | zero => simp + 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₂]) @@ -2110,53 +2107,54 @@ instance instMonoidalCategory : MonoidalCategory SuperVect := /-! ### 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 {Y Z} f => 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.induction_on with - | zero => simp - | 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.induction_on with - | zero => simp - | 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.induction_on with - | zero => simp - | 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.induction_on with - | zero => simp - | tmul a b => simp [TensorProduct.comm_tmul, TensorProduct.map_tmul] - | add x₁ x₂ hx₁ hx₂ => simp only [map_add, hx₁, hx₂] + braiding_naturality_right := fun X {_ _} f => koszulBraiding_naturality_right X f braiding_naturality_left := fun {X Y} f Z => by apply Hom.ext · -- even component @@ -2171,12 +2169,10 @@ instance instBraidedCategory : BraidedCategory SuperVect where koszulBraidingEven, koszulEvenAux, LinearMap.neg_apply, LinearEquiv.coe_toLinearMap, Prod.mk.injEq] refine ⟨?_, ?_⟩ - · induction x using TensorProduct.induction_on with - | zero => simp + · 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.induction_on with - | zero => simp + · induction y using TensorProduct.inductionOn with | tmul a b => simp [TensorProduct.comm_tmul, TensorProduct.map_tmul, map_neg] | add y₁ y₂ hy₁ hy₂ => @@ -2192,12 +2188,10 @@ instance instBraidedCategory : BraidedCategory SuperVect where simp only [LinearMap.comp_apply, LinearMap.prodMap_apply, koszulBraidingOdd_pair, Prod.mk.injEq] refine ⟨?_, ?_⟩ - · induction y using TensorProduct.induction_on with - | zero => simp + · 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.induction_on with - | zero => simp + · 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 @@ -2311,15 +2305,15 @@ componentwise. -/ instance instPreadditive : Preadditive SuperVect where add_comp _ _ _ f f' g := by apply Hom.ext - · show g.evenMap ∘ₗ (f.evenMap + f'.evenMap) = _ + · change g.evenMap ∘ₗ (f.evenMap + f'.evenMap) = _ exact LinearMap.comp_add _ _ _ - · show g.oddMap ∘ₗ (f.oddMap + f'.oddMap) = _ + · change g.oddMap ∘ₗ (f.oddMap + f'.oddMap) = _ exact LinearMap.comp_add _ _ _ comp_add _ _ _ f g g' := by apply Hom.ext - · show (g.evenMap + g'.evenMap) ∘ₗ f.evenMap = _ + · change (g.evenMap + g'.evenMap) ∘ₗ f.evenMap = _ exact LinearMap.add_comp _ _ _ - · show (g.oddMap + g'.oddMap) ∘ₗ f.oddMap = _ + · change (g.oddMap + g'.oddMap) ∘ₗ f.oddMap = _ exact LinearMap.add_comp _ _ _ /-- SuperVect is ℂ-linear: composition is ℂ-bilinear @@ -2327,15 +2321,15 @@ componentwise. -/ instance instLinear : CategoryTheory.Linear ℂ SuperVect where smul_comp _ _ _ c f g := by apply Hom.ext - · show g.evenMap ∘ₗ (c • f.evenMap) = _ + · change g.evenMap ∘ₗ (c • f.evenMap) = _ exact LinearMap.comp_smul _ _ _ - · show g.oddMap ∘ₗ (c • f.oddMap) = _ + · change g.oddMap ∘ₗ (c • f.oddMap) = _ exact LinearMap.comp_smul _ _ _ comp_smul _ _ _ f c g := by apply Hom.ext - · show (c • g.evenMap) ∘ₗ f.evenMap = _ + · change (c • g.evenMap) ∘ₗ f.evenMap = _ exact LinearMap.smul_comp _ _ _ - · show (c • g.oddMap) ∘ₗ f.oddMap = _ + · change (c • g.oddMap) ∘ₗ f.oddMap = _ exact LinearMap.smul_comp _ _ _ end SuperVect @@ -2371,7 +2365,7 @@ 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 - haveI : IsSplitMono i := ⟨⟨r, h⟩⟩ + have : IsSplitMono i := ⟨⟨r, h⟩⟩ exact ⟨Y, i, 𝟙 Y, inferInstance, inferInstance⟩ /-- `LengthLE Y k` states that the subobject order of `Y` contains diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjSwapBmc.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjSwapBmc.lean index 0eeca930f3..dadcb02a93 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjSwapBmc.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjSwapBmc.lean @@ -32,11 +32,11 @@ theorem swap_val {m : ℕ} (a b x : Fin m) : 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 [if_pos h1, if_pos (by rw [h1])] - · rw [if_neg h1, if_neg (fun hv => h1 (Fin.ext hv))] + · 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 [if_pos h2, if_pos (by rw [h2])] - · rw [if_neg h2, if_neg (fun hv => h2 (Fin.ext hv))] + · 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) @@ -56,30 +56,30 @@ theorem tensorMapEquiv_top (n : ℕ) : 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] - show x.val = _ - rw [if_neg (show ¬ (x.val = n) by omega), - if_neg (show ¬ (x.val = n + 1) by omega)] + 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 show x.val = n + 0; omega), + 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) _ _] - show n + (1 + 0) = _ - rw [if_pos hv] + change n + (1 + 0) = _ + rw [ite_eq_left hv] · conv_lhs => rw [show x = Fin.natAdd n ⟨1, by omega⟩ from - Fin.ext (by show x.val = n + 1; omega), + 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) _ _] - show n + 0 = _ - rw [if_neg (show ¬ (x.val = n) by omega), if_pos hv] + 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. -/ @@ -92,16 +92,16 @@ theorem tensorMapEquiv_whisker (n i : ℕ) (h : i + 2 ≤ n + 1) : 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] - show ((adjSwapEquiv (n + 1) i h) ⟨x.val, hx⟩).val = _ + 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 show x.val = n + 1 + 0; omega), + from Fin.ext (by change x.val = n + 1 + 0; omega), tensorMapEquiv_natAdd] - show n + 1 + 0 = _ - rw [if_neg (show ¬ (x.val = i) by omega), - if_neg (show ¬ (x.val = i + 1) by omega)] + 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) @@ -119,8 +119,8 @@ theorem skeinPowBraid_bmc : · rw [show skeinPowBraid f (n + 2) i h = (SkeinObj.mk n : SkeinObj f) ◁ (β_ (SkeinObj.mk 1 : SkeinObj f) - (SkeinObj.mk 1)).hom from dif_pos hi] - show HomSpace.tensor f n n 2 2 + (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] @@ -128,9 +128,9 @@ theorem skeinPowBraid_bmc : · 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 - dif_neg hi] + dite_eq_right hi] rw [skeinPowBraid_bmc (n + 1) i hle] - show HomSpace.tensor f (n + 1) (n + 1) 1 1 + 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, diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisCoord.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisCoord.lean index 2f6714524a..5bd0bb14e6 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisCoord.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisCoord.lean @@ -30,7 +30,7 @@ theorem coordOf_evenBasisVec {n : ℕ} {c : MixedColouring k ℓ n // c.IsEven})) c' = (colourPowerEquiv k ℓ n).evenEquiv (evenBasisVec ⟨c, hc⟩) ⟨c', hc'⟩ from by - unfold coordOf; rw [dif_pos hc']] + unfold coordOf; rw [dite_eq_left hc']] rw [show (colourPowerEquiv k ℓ n).evenEquiv (evenBasisVec (⟨c, hc⟩ : {c : MixedColouring k ℓ n // c.IsEven})) = @@ -38,13 +38,13 @@ theorem coordOf_evenBasisVec {n : ℕ} (colourPowerEquiv k ℓ n).evenEquiv.apply_symm_apply _] by_cases he : c' = c · subst he - rw [if_pos rfl] + rw [ite_eq_left rfl] exact Pi.single_eq_same _ _ - · rw [if_neg he] + · rw [ite_eq_right he] exact Pi.single_eq_of_ne (fun h => he (congrArg Subtype.val h)) _ · rw [coordOf_odd _ _ hc'] - rw [if_neg (fun he : c' = c => hc' (he ▸ hc))] + rw [ite_eq_right (fun he : c' = c => hc' (he ▸ hc))] /-- The arity-zero basis vector is the unit scalar. -/ theorem evenBasisVec_zeroArity diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisSplit.lean index ed39de9d0e..6a8b954802 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisSplit.lean @@ -77,7 +77,7 @@ theorem evenBasisVec_split {a b : ℕ} -- 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 [dif_pos h] + · rw [dite_eq_left h] rw [show ((colourPowerEquiv k ℓ (a + b)).evenEquiv (((powMerge (stdSuperPair k ℓ) a b) : SuperVect.Hom _ _).evenMap @@ -94,7 +94,7 @@ theorem evenBasisVec_split {a b : ℕ} ⟨c'.secondHalf, c'.secondHalf_isEven hc' h'⟩ else 0) from colourMerge_coord a b _ _ c' hc'] by_cases h' : MixedColouring.IsEven c'.firstHalf - · rw [dif_pos h'] + · rw [dite_eq_left h'] rw [show (colourPowerEquiv k ℓ a).evenEquiv (evenBasisVec ⟨c.firstHalf, h⟩) = Pi.single ⟨c.firstHalf, h⟩ 1 from @@ -125,10 +125,10 @@ theorem evenBasisVec_split {a b : ℕ} · rw [single_val_ne ⟨c.firstHalf, h⟩ ⟨c'.firstHalf, h'⟩ hf] rw [zero_mul] - · rw [dif_neg h'] + · rw [dite_eq_right h'] have hne : c' ≠ c := fun he => h' (he ▸ h) rw [single_val_ne ⟨c, hc⟩ ⟨c', hc'⟩ hne] - · rw [dif_neg h] + · rw [dite_eq_right h] rw [show ((colourPowerEquiv k ℓ (a + b)).evenEquiv (((powMerge (stdSuperPair k ℓ) a b) : SuperVect.Hom _ _).evenMap @@ -151,10 +151,10 @@ theorem evenBasisVec_split {a b : ℕ} c'.secondHalf_not_isEven' hc' h'⟩) from colourMerge_coord_oddPair a b _ _ c' hc'] by_cases h' : MixedColouring.IsEven c'.firstHalf - · rw [dif_pos h'] + · rw [dite_eq_left h'] have hne : c' ≠ c := fun he => h (he ▸ h') rw [single_val_ne ⟨c, hc⟩ ⟨c', hc'⟩ hne] - · rw [dif_neg h'] + · rw [dite_eq_right h'] rw [show (colourPowerEquiv k ℓ a).oddEquiv (oddBasisVec ⟨c.firstHalf, h⟩) = Pi.single ⟨c.firstHalf, h⟩ 1 from diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaData.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaData.lean index 1537d55b1f..fa068eb60e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaData.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaData.lean @@ -15,7 +15,7 @@ index on either side, and the `β`-diagonal these produce. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} @@ -27,18 +27,18 @@ theorem colourFormEntry_inr_partner (u : Fin (2 * ℓ)) : have hu := u.isLt unfold oddPartner oddPartnerSign by_cases h : u.val < ℓ - · rw [dif_pos h, if_pos h] - show (if u.val + ℓ = u.val + ℓ then (1 : ℂ) + · 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 [if_pos rfl] + rw [ite_eq_left rfl] simp - · rw [dif_neg h, if_neg h] - show (if u.val + ℓ = u.val - ℓ then (1 : ℂ) + · 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 [if_neg h1, if_pos (by omega)] + rw [ite_eq_right h1, ite_eq_left (by omega)] simp /-- The data colouring at a castAdd slot gives the representative @@ -59,8 +59,8 @@ theorem colouringOf_castAdd (W : ClosedFragment) (F : EdgeSubset W) intro slot hslot rw [colouringOf] by_cases h : (starFlagEnum W).symm slot ∈ F.flags - · rw [dif_pos h, dif_pos h, if_pos hslot] - · rw [dif_neg h, dif_neg h] + · 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 @@ -85,15 +85,15 @@ theorem colouringOf_natAdd (W : ClosedFragment) (F : EdgeSubset W) intro slot hslot rw [colouringOf] by_cases h : (starFlagEnum W).symm slot ∈ F.flags - · rw [dif_pos h, dif_pos h, if_neg hslot] - · rw [dif_neg h, dif_neg h] + · 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 - show ¬ (edgeCount W + i.val < edgeCount W); omega)] + 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 [dif_pos h', dif_pos 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}) = @@ -107,7 +107,7 @@ theorem colouringOf_natAdd (W : ClosedFragment) (F : EdgeSubset W) have := F.pairing_mem _ hmem rw [W.pairing_invol] at this exact this) - rw [dif_neg h', dif_neg h] + 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}) = @@ -142,15 +142,15 @@ theorem betaDiag_colouringOf (W : ClosedFragment) (F : EdgeSubset W) -- Show the products agree entry-by-entry refine Finset.prod_congr rfl (fun i _ => ?_) -- Convert firstHalf/secondHalf to castAdd/natAdd - show colourFormEntry k ℓ + 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 [dif_pos h, dif_pos h, dif_pos h] + · rw [dite_eq_left h, dite_eq_left h, dite_eq_left h] exact colourFormEntry_inr_partner _ - · rw [dif_neg h, dif_neg h, dif_neg h] - show (if (ψ.val ⟨_, h⟩) = (ψ.val ⟨_, h⟩) then (1 : ℂ) else 0) = 1 - rw [if_pos rfl] + · 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 index 798d804511..8dbe5ce604 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiag.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiag.lean @@ -46,7 +46,7 @@ theorem eq_peelColour_of (m : ℕ) subst hspec apply Eq.symm funext j - show c' (finCongr (capPeelArity m) ((capPeelPerm m) + change c' (finCongr (capPeelArity m) ((capPeelPerm m) ((capPeelPerm m)⁻¹ ((finCongr (capPeelArity m)).symm j)))) = c' j rw [show (capPeelPerm m) ((capPeelPerm m)⁻¹ @@ -66,7 +66,7 @@ theorem peelColour_isEven (m : ℕ) (c ∘ ⇑((capPeelPerm m)⁻¹)) ∘ ⇑(finCongr (capPeelArity m).symm) := by funext j - show c ((capPeelPerm m)⁻¹ + change c ((capPeelPerm m)⁻¹ ((finCongr (capPeelArity m)).symm j)) = _ rfl rw [h2] @@ -89,9 +89,9 @@ theorem peelColour_low (m : ℕ) peelColour m c j = c ⟨j.val, by omega⟩ := by rw [peelColour_apply] refine congrArg c (Fin.ext ?_) - show capPeelInv m j.val = j.val + change capPeelInv m j.val = j.val unfold capPeelInv - rw [if_pos h] + rw [ite_eq_left h] /-- The second peeled-pair slot carries the last slot. -/ theorem peelColour_pairSnd (m : ℕ) @@ -100,9 +100,9 @@ theorem peelColour_pairSnd (m : ℕ) c ⟨(m + 1) + m, by omega⟩ := by rw [peelColour_apply] refine congrArg c (Fin.ext ?_) - show capPeelInv m ((m + m) + 1) = (m + 1) + m + change capPeelInv m ((m + m) + 1) = (m + 1) + m unfold capPeelInv - rw [if_neg (by omega), if_neg (by omega), if_neg (by omega)] + 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiagForm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiagForm.lean index 42ae066a4b..fa9b3c1a27 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiagForm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiagForm.lean @@ -32,7 +32,7 @@ private theorem peelFirstHalf_firstHalf (m : ℕ) (peelColour m c)) = fun (i : Fin m) => c ⟨i.val, by omega⟩ := by funext i - show peelColour m c ⟨i.val, by omega⟩ = c ⟨i.val, by omega⟩ + 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 @@ -44,11 +44,11 @@ private theorem peelFirstHalf_secondHalf (m : ℕ) (peelColour m c)) = fun (j : Fin m) => c ⟨(m + 1) + j.val, by omega⟩ := by funext j - show peelColour m c ⟨m + j.val, by omega⟩ = + change peelColour m c ⟨m + j.val, by omega⟩ = c ⟨(m + 1) + j.val, by omega⟩ rw [peelColour_apply] refine congrArg c (Fin.ext ?_) - show capPeelInv m (m + j.val) = (m + 1) + j.val + 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. -/ @@ -56,10 +56,10 @@ 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 - show peelColour m c ⟨(m + m) + 0, by omega⟩ = c ⟨m, by omega⟩ + change peelColour m c ⟨(m + m) + 0, by omega⟩ = c ⟨m, by omega⟩ rw [peelColour_apply] refine congrArg c (Fin.ext ?_) - show capPeelInv m ((m + m) + 0) = m + 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. -/ @@ -81,7 +81,7 @@ private theorem firstHalf_castSucc_eq (m : ℕ) MixedColouring.firstHalf (a := m) (b := m) (MixedColouring.firstHalf (a := m + m) (b := 2) (peelColour m c)) i := by - show c ⟨(Fin.castSucc i).val, by omega⟩ = _ + change c ⟨(Fin.castSucc i).val, by omega⟩ = _ rw [peelFirstHalf_firstHalf] exact congrArg c (Fin.ext rfl) @@ -95,7 +95,7 @@ private theorem secondHalf_castSucc_eq (m : ℕ) MixedColouring.secondHalf (a := m) (b := m) (MixedColouring.firstHalf (a := m + m) (b := 2) (peelColour m c)) j := by - show c ⟨(m + 1) + (Fin.castSucc j).val, by omega⟩ = _ + change c ⟨(m + 1) + (Fin.castSucc j).val, by omega⟩ = _ rw [peelFirstHalf_secondHalf] exact congrArg c (Fin.ext rfl) @@ -350,7 +350,7 @@ private theorem sign_eq (m : ℕ) obtain ⟨ha_eq, hb_lo, hb_hi⟩ := hinv a b hab hgt refine mem_filter.mpr ⟨mem_filter.mpr ⟨mem_univ _, ?_, ?_, ?_⟩, rfl⟩ - · show b.val - (m + 1) < m; omega + · 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 := @@ -361,7 +361,7 @@ private theorem sign_eq (m : ℕ) (⟨b.val - (m + 1), by omega⟩ : Fin (m + 1)) = b := Fin.ext (by simp; omega) - rw [hsHc_def]; show (c (Fin.natAdd (m + 1) + 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 @@ -388,7 +388,7 @@ private theorem sign_eq (m : ℕ) ?_, ?_⟩ · simp only [mem_filter, mem_univ, true_and] refine ⟨show m < (m + 1) + i.val by omega, ?_, ?_, ?_⟩ - · show (capPeelPerm m + · change (capPeelPerm m ⟨(m + 1) + i.val, _⟩).val < (capPeelPerm m ⟨m, _⟩).val rw [hσm, hσi ⟨i.val, hi_lt⟩]; omega @@ -440,7 +440,7 @@ theorem betaDiag_eq_betaColour {k ℓ : ℕ} : · -- All pairs match: the main computation have heven := peelFirstHalf_isEven_of_matching m c hmatch rw [betaDiag_succ] - rw [dif_pos heven] + rw [dite_eq_left heven] -- Apply the inductive hypothesis rw [ih] -- Unfold betaColour on both sides diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaFlip.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaFlip.lean index 29fab0ea04..2c51e38530 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaFlip.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaFlip.lean @@ -21,7 +21,7 @@ representative parities times the Definition 5 odd signs. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockAlign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockAlign.lean index cef628f67e..55b4c89a36 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockAlign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockAlign.lean @@ -19,7 +19,7 @@ their colour, incoming flags the colour itself. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} @@ -58,7 +58,7 @@ theorem blockRestrict_colouringOfFlip_mem (W : ClosedFragment) blockRestrict_colouringOf_mem W F _ _ v j h] congr 1 by_cases hlow : (slotEmbed W v j).val < edgeCount W - · rw [if_pos hlow] + · rw [ite_eq_left hlow] have hrep : repFlag W (blockFlag W v j) = blockFlag W v j := repFlag_low W _ (by @@ -70,15 +70,15 @@ theorem blockRestrict_colouringOfFlip_mem (W : ClosedFragment) rw [hrep] exact hout) rw [EdgeSubset.OddColouring.flip_val_mem F _ _ φ - ⟨blockFlag W v j, h⟩ hT, if_pos hout] + ⟨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, if_neg hout] - · rw [if_neg hlow] + ⟨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 @@ -95,7 +95,7 @@ theorem blockRestrict_colouringOfFlip_mem (W : ClosedFragment) rw [hrep, hpair, hout] at h2 exact Bool.noConfusion h2 rw [EdgeSubset.OddColouring.flip_val_not_mem F _ _ φ - ⟨blockFlag W v j, h⟩ hT, if_pos hout] + ⟨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 @@ -106,7 +106,7 @@ theorem blockRestrict_colouringOfFlip_mem (W : ClosedFragment) rfl) rw [EdgeSubset.OddColouring.flip_val_mem F _ _ φ ⟨blockFlag W v j, h⟩ hT, oddPartner_invol, - if_neg hout] + ite_eq_right hout] /-- Non-participating block values are unchanged by the flip. -/ theorem blockRestrict_colouringOfFlip_not_mem diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockCanon.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockCanon.lean index fd4900fa3e..54cdefa193 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockCanon.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockCanon.lean @@ -19,7 +19,7 @@ Definition 5 odd values. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} @@ -98,7 +98,7 @@ theorem oddListOf_coe_multiset {d : ℕ} have hnr : ¬ (c x).isRight = true := fun hr => hxs ((hs x).mpr hr) rcases hy : c x with a | u - · show Sum.getRight? (c x) = none + · change Sum.getRight? (c x) = none rw [hy] rfl · exact absurd (by rw [hy]; rfl) hnr @@ -115,7 +115,7 @@ theorem oddListOf_coe_multiset {d : ℕ} · rw [hy] at hr exact Bool.noConfusion hr · exact ⟨u, rfl⟩ - show Sum.getRight? (c j.val) = + 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 @@ -159,7 +159,7 @@ theorem evenMultisetOf_coe {d : ℕ} fun hl => hxs ((hs x).mpr hl) rcases hy : c x with a | u · exact absurd (by rw [hy]; rfl) hnl - · show Sum.getLeft? (c x) = none + · change Sum.getLeft? (c x) = none rw [hy] rfl rw [hfil, hzero, add_zero] @@ -175,7 +175,7 @@ theorem evenMultisetOf_coe {d : ℕ} · exact ⟨a, rfl⟩ · rw [hy] at hl exact Bool.noConfusion hl - show Sum.getLeft? (c j.val) = + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockData.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockData.lean index cc8ed14254..ebb3107961 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockData.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockData.lean @@ -17,7 +17,7 @@ colour (or its partner on partner slots), the rest the even colour. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} @@ -40,6 +40,7 @@ theorem blockFlag_injective (W : ClosedFragment) 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. -/ @@ -57,11 +58,11 @@ theorem image_blockFlag (W : ClosedFragment) · intro hvtx have hassign : starAssignEnum W (starFlagEnum W g) = finCongr (degList_length (starAssignEnum W)) v := by - show (Fintype.equivFin W.Vertex) + change (Fintype.equivFin W.Vertex) (starAssign W (starFlagEnum W g)) = _ have hv : starAssign W (starFlagEnum W g) = blockVertex W v := by - show ClosedFragment.vertexOf W + change ClosedFragment.vertexOf W ((starFlagEnum W).symm (starFlagEnum W g)) = blockVertex W v rw [_root_.Equiv.symm_apply_apply, hvtx] @@ -76,7 +77,7 @@ theorem image_blockFlag (W : ClosedFragment) simp only at hfst rcases hfst with rfl refine ⟨jw, ?_⟩ - show (starFlagEnum W).symm (slotEmbed W w jw) = g + 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] @@ -107,7 +108,7 @@ theorem blockRestrict_colouringOf_not_mem (W : ClosedFragment) blockRestrict (ds W) (cSorted W (colouringOf W F ψ φ)) v j = Sum.inl (ψ.val ⟨blockFlag W v j, h⟩) := by - rw [blockRestrict_colouringOf, dif_neg h] + rw [blockRestrict_colouringOf, dite_eq_right h] /-- Participating block flags carry the odd colour or its partner. -/ @@ -122,7 +123,7 @@ theorem blockRestrict_colouringOf_mem (W : ClosedFragment) φ.val ⟨blockFlag W v j, h⟩ else oddPartner ℓ (φ.val ⟨blockFlag W v j, h⟩)) := by - rw [blockRestrict_colouringOf, dif_pos h] + rw [blockRestrict_colouringOf, dite_eq_left h] open Classical in /-- The non-participating slots of a block. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockOddList.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockOddList.lean index 180d9e93f8..ad93d819bc 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockOddList.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockOddList.lean @@ -17,7 +17,7 @@ entry by entry. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockParity.lean index e0c9e5a8f1..3e830636de 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockParity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockParity.lean @@ -18,7 +18,7 @@ summand vanishes whenever any block is odd-parity. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} @@ -100,7 +100,7 @@ theorem vertexOf_slotEmbed (W : ClosedFragment) apply (Fintype.equivFin W.Vertex).injective -- Goal: equivFin (vertexOf W ((starFlagEnum W).symm (slotEmbed W v j))) -- = equivFin (blockVertex W v) - show starAssignEnum W (slotEmbed W v j) = + change starAssignEnum W (slotEmbed W v j) = (Fintype.equivFin W.Vertex) (blockVertex W v) rw [assign_slotEmbed, blockVertex, _root_.Equiv.apply_symm_apply] @@ -129,16 +129,17 @@ theorem slotEmbed_recover (W : ClosedFragment) Fin ((ds W).get _w)) = sortSigma (starAssignEnum W) s) : slotEmbed W v jw = s := by - show (sortEquiv (starAssignEnum W)).symm + change (sortEquiv (starAssignEnum W)).symm (blockSigmaEquiv (ds W) ⟨v, jw⟩) = s have hbe : blockSigmaEquiv (ds W) ⟨v, jw⟩ = sortEquiv (starAssignEnum W) s := by - show blockSigmaEquiv (ds W) ⟨v, jw⟩ = + 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. -/ @@ -178,9 +179,9 @@ theorem blockRestrict_oddSet_card (W : ClosedFragment) -- The assignment of s matches block v have hassign : starAssignEnum W s = finCongr (degList_length (starAssignEnum W)) v := by - show (Fintype.equivFin W.Vertex) (starAssign W s) = _ + change (Fintype.equivFin W.Vertex) (starAssign W s) = _ have hv : starAssign W s = blockVertex W v := by - show ClosedFragment.vertexOf W + change ClosedFragment.vertexOf W ((starFlagEnum W).symm s) = blockVertex W v rw [hsg, hvtx] rw [hv, blockVertex, _root_.Equiv.apply_symm_apply] @@ -208,6 +209,7 @@ theorem blockRestrict_oddSet_card (W : ClosedFragment) 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockRestrict.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockRestrict.lean index cee0e9a119..357bb2ca6c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockRestrict.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockRestrict.lean @@ -49,7 +49,7 @@ theorem blockSigmaEquiv_strictMono : match v with | ⟨0, hv⟩ => intro j₁ j₂ hj - show blockSigmaEquiv (d :: ds) ⟨⟨0, hv⟩, j₁⟩ < + change blockSigmaEquiv (d :: ds) ⟨⟨0, hv⟩, j₁⟩ < blockSigmaEquiv (d :: ds) ⟨⟨0, hv⟩, j₂⟩ rw [Fin.lt_def] have h1 : (blockSigmaEquiv (d :: ds) @@ -65,7 +65,7 @@ theorem blockSigmaEquiv_strictMono : simp only [List.length_cons] at h omega have hrec := blockSigmaEquiv_strictMono ds ⟨w, hw⟩ hj - show blockSigmaEquiv (d :: ds) ⟨⟨w + 1, hv⟩, j₁⟩ < + change blockSigmaEquiv (d :: ds) ⟨⟨w + 1, hv⟩, j₁⟩ < blockSigmaEquiv (d :: ds) ⟨⟨w + 1, hv⟩, j₂⟩ rw [Fin.lt_def] have h1 : (blockSigmaEquiv (d :: ds) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSigma.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSigma.lean index 61aba9a3cd..81dbc17530 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSigma.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSigma.lean @@ -77,17 +77,17 @@ theorem blockAssign_blockSigmaEquiv (ds : List ℕ) -- sumCongr → inl j -- finSumFinEquiv → castAdd ds.sum j -- finCongr → same val - show blockAssign (d :: ds) (blockSigmaEquiv (d :: ds) ⟨⟨0, hv⟩, j⟩) = + 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 [dif_pos hlt] + rw [dite_eq_left hlt] | v + 1 => -- p = ⟨⟨v+1, hv⟩, j⟩ where j : Fin (ds.get ⟨v, _⟩) - show blockAssign (d :: ds) (blockSigmaEquiv (d :: ds) ⟨⟨v + 1, hv⟩, j⟩) = + 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 @@ -97,7 +97,7 @@ theorem blockAssign_blockSigmaEquiv (ds : List ℕ) have hnlt : ¬ (blockSigmaEquiv (d :: ds) ⟨⟨v + 1, hv⟩, j⟩).val < d := by rw [hval]; omega unfold blockAssign - rw [dif_neg hnlt] + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSort.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSort.lean index 31796fb1c8..c7287bf603 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSort.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSort.lean @@ -136,11 +136,11 @@ noncomputable def multiStarCompRelabel {V V' : Type} vertexEquiv := e attach_comm := fun g => by rcases g with i | i - · show Sum.inl (b (σ i)) = + · change Sum.inl (b (σ i)) = (Sum.inl (assign i) : V ⊕ Fin n).map e id rw [hb i] rfl - · show Sum.inr (σ.symm (σ i)) = + · change Sum.inr (σ.symm (σ i)) = (Sum.inr i : V ⊕ Fin n).map e id rw [σ.symm_apply_apply] rfl diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BraidWord.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BraidWord.lean index d5b27173d7..c4e0f10f8e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BraidWord.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BraidWord.lean @@ -51,7 +51,7 @@ theorem stdToOmega_bmc_word {n : ℕ} (w : List (Fin n)) : (Fin (n + 1))) : Fin (n + 1) ≃ Fin (n + 1))) = powBraidWord (stdSuperPair k ℓ) w ≫ stdToOmega f P e (n + 1) := by - letI := P.braided + let := P.braided induction w with | nil => rw [List.map_nil, List.prod_nil] @@ -68,7 +68,7 @@ theorem stdToOmega_bmc_word {n : ℕ} (w : List (Fin n)) : SkeinObj f)) = 𝟙 (P.ω.obj (SkeinObj.mk (n + 1))) := P.ω.map_id _ rw [hmapid] - show stdToOmega f P e (n + 1) ≫ 𝟙 _ = + change stdToOmega f P e (n + 1) ≫ 𝟙 _ = 𝟙 _ ≫ stdToOmega f P e (n + 1) rw [Category.comp_id, Category.id_comp] | cons i w ih => @@ -128,7 +128,7 @@ theorem stdToOmega_bmc_perm {n : ℕ} (σ : Fin (n + 1) ≃ Fin (n + 1))) = powBraidWord (stdSuperPair k ℓ) (adjWord σ) ≫ stdToOmega f P e (n + 1) := by - letI := P.braided + let := P.braided have h := stdToOmega_bmc_word f P e (adjWord σ) rw [adjWord_spec σ] at h exact h diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonColour.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonColour.lean index a6d6d28381..97af79ab9b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonColour.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonColour.lean @@ -40,7 +40,7 @@ theorem canonColouring_isRight_low (μm : Multiset (Fin k)) (i : Fin (μm.card + F.card)) (h : i.val < μm.card) : (canonColouring μm F i).isRight = false := by unfold canonColouring - rw [dif_pos h] + rw [dite_eq_left h] rfl /-- High positions are odd colours. -/ @@ -49,7 +49,7 @@ theorem canonColouring_isRight_high (μm : Multiset (Fin k)) (i : Fin (μm.card + F.card)) (h : ¬ i.val < μm.card) : (canonColouring μm F i).isRight = true := by unfold canonColouring - rw [dif_neg h] + 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 index 1ee67ed3c0..c62e5032bd 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean @@ -97,7 +97,7 @@ private theorem colourValueRank_injective : cases x with | inl a => cases y with - | inl b => simp [colourValueRank] at hxy; exact congrArg Sum.inl (Fin.ext + | inl b => simp? [colourValueRank] at hxy; exact congrArg Sum.inl (Fin.ext hxy) | inr b => simp [colourValueRank] at hxy; omega | inr a => @@ -134,7 +134,7 @@ private theorem vr_comp_sigma_mono {d : ℕ} (c : MixedColouring k ℓ d) (_hd : | inl ai => cases hcj : c sj with | inl aj => - show ai.val ≤ aj.val + 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 := @@ -143,7 +143,7 @@ private theorem vr_comp_sigma_mono {d : ℕ} (c : MixedColouring k ℓ d) (_hd : have hsi := si.isLt; have hsj := sj.isLt nlinarith | inr bj => - show ai.val ≤ k + bj.val + change ai.val ≤ k + bj.val have hai := ai.isLt; omega | inr bi => cases hcj : c sj with @@ -157,7 +157,7 @@ private theorem vr_comp_sigma_mono {d : ℕ} (c : MixedColouring k ℓ d) (_hd : have haj := aj.isLt; have hsj := sj.isLt nlinarith | inr bj => - show k + bi.val ≤ k + bj.val + 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 @@ -178,14 +178,14 @@ private theorem vr_comp_canon_mono (μm : Multiset (Fin k)) (F : Finset (Fin (2 simp only split_ifs with h1 h2 h2 · -- both left: sorted even values - show colourValueRank k (Sum.inl _) ≤ colourValueRank k (Sum.inl _) + 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 (Fin.mk_le_mk.mpr (by omega) : (⟨i, hlen ▸ h1⟩ : Fin _) ≤ ⟨j, hlen ▸ h2⟩) · -- left ≤ right - show colourValueRank k (Sum.inl _) ≤ colourValueRank k (Sum.inr _) + 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 @@ -193,7 +193,7 @@ private theorem vr_comp_canon_mono (μm : Multiset (Fin k)) (F : Finset (Fin (2 · -- right, left: impossible exfalso; omega · -- both right: sorted odd values - show colourValueRank k (Sum.inr _) ≤ colourValueRank k (Sum.inr _) + change colourValueRank k (Sum.inr _) ≤ colourValueRank k (Sum.inr _) simp only [colourValueRank] show k + _ ≤ k + _ have hpw := Finset.pairwise_sort F (· ≤ ·) @@ -238,10 +238,10 @@ private theorem canon_as_concat (μm : Multiset (Fin k)) (F : Finset (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 [dif_pos hfin, List.getElem_append_left (by omega)] + 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 [dif_neg hfin, List.getElem_append_right (by omega)] + rw [dite_eq_right hfin, List.getElem_append_right (by omega)] simp [hlen_l, List.getElem_map] /-! ## Multiset equality between c and canon -/ @@ -299,7 +299,7 @@ private theorem pairInv_perm_inv {n : ℕ} (f : Perm (Fin n)) : · simp only [mem_filter, mem_univ, true_and] constructor · exact hmem.2 - · show f (f.symm j) > f (f.symm i) + · 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⟩ @@ -400,17 +400,17 @@ theorem filterMap_ofFn_sorted {β γ : Type*} · intro a b hab have ha := hpos a have hlt : (ps a).val < (ps b).val := hps hab - show (ps a).val - 1 < (ps b).val - 1 + 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 - show g (f (⟨(ps t).val - 1, hbd t⟩ : Fin d).succ) = some (vals t) + 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; show (ps t).val - 1 = q.val + 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 => @@ -445,7 +445,7 @@ theorem filterMap_ofFn_sorted {β γ : Type*} 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 - show 0 < t.val + 1; omega) + 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 @@ -454,13 +454,13 @@ theorem filterMap_ofFn_sorted {β γ : Type*} · 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 show a.val + 1 < b.val + 1; omega) - show (ps a.succ).val - 1 < (ps b.succ).val - 1 + 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 - show g (f (⟨(ps t.succ).val - 1, hbd t⟩ : Fin d).succ) = some (vals + 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 @@ -473,7 +473,7 @@ theorem filterMap_ofFn_sorted {β γ : Type*} Fin.val heq) (by simp [Fin.val_succ]) · intro heq; apply hne ⟨t', by omega⟩ - apply Fin.ext; show (ps (⟨t' + 1, ht⟩ : Fin (n' + 1))).val - 1 = q.val + 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 @@ -522,7 +522,7 @@ private theorem canonSortPerm_sign {d : ℕ} (c : MixedColouring k ℓ d) apply Fin.ext show a.val = b.val have := congrArg Fin.val hinj - simp at this; exact this + simp? 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 => @@ -551,13 +551,13 @@ private theorem canonSortPerm_sign {d : ℕ} (c : MixedColouring k ℓ d) rw [isRight_comp] at hr1 hr2 simp only [decide_eq_true_eq] at hr1 hr2 constructor - · show p₁.val - m < p₂.val - m; omega + · change p₁.val - m < p₂.val - m; omega · have he1 : g ⟨p₁.val - m, by omega⟩ = σ p₁ := by - show σ ⟨m + (p₁.val - m), _⟩ = σ p₁ - congr 1; apply Fin.ext; show m + (p₁.val - m) = p₁.val; omega + 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 - show σ ⟨m + (p₂.val - m), _⟩ = σ p₂ - congr 1; apply Fin.ext; show m + (p₂.val - m) = p₂.val; omega + 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 @@ -567,15 +567,15 @@ private theorem canonSortPerm_sign {d : ℕ} (c : MixedColouring k ℓ d) 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 show a₁.val = a₂.val; omega)) - (Fin.ext (by show b₁.val = b₂.val; omega)) + 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 show m + t₁.val < m + t₂.val; omega, hgt_t, ?_, ?_⟩ + 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 _ @@ -608,9 +608,9 @@ private theorem canonSortPerm_sign {d : ℕ} (c : MixedColouring k ℓ d) unfold canonColouring have hge : ¬ (finCongr h ⟨m + (π t).val, by omega⟩).val < m := by simp [finCongr_apply] - rw [dif_neg hge] + rw [dite_eq_right hge] simp only [Sum.getRight?_inr, Option.some.injEq] - show (F.sort (· ≤ ·)).get + 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] @@ -622,9 +622,9 @@ private theorem canonSortPerm_sign {d : ℕ} (c : MixedColouring k ℓ d) 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 - show σ ⟨m + ((σ.symm q).val - m), _⟩ = q + change σ ⟨m + ((σ.symm q).val - m), _⟩ = q rw [show (⟨m + ((σ.symm q).val - m), _⟩ : Fin d) = σ.symm q from - Fin.ext (by show m + ((σ.symm q).val - m) = (σ.symm q).val; omega)] + 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] @@ -636,11 +636,11 @@ private theorem canonSortPerm_sign {d : ℕ} (c : MixedColouring k ℓ d) canonColouring (evenMultisetOf c) F (finCongr h (σ.symm q)) from congr_fun comp _] unfold canonColouring - rw [dif_pos (by simp [finCongr_apply]; exact hq_low)] + rw [dite_eq_left (by simp? [finCongr_apply]; exact hq_low)] exact Sum.getRight?_inl -- Step 3c: structural claim have step3 : oddListOf c = List.ofFn (v ∘ π) := by - show (List.ofFn c).filterMap Sum.getRight? = List.ofFn (v ∘ π) + 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 ═══════ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapClosed.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapClosed.lean index 5a7e68f09d..d6f1d95fe3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapClosed.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapClosed.lean @@ -50,7 +50,7 @@ theorem capVal_closed rw [capVal_zero, evenBasisVec_zeroArity, betaDiag_zero] | succ m ih => intro c hc - letI := P.braided + let := P.braided rw [capVal_succ, splitCapVal_expansion, betaDiag_succ] have hterm : ∀ c' : {c' : MixedColouring k ℓ ((m + m) + 2) // c'.IsEven}, @@ -91,12 +91,12 @@ theorem capVal_closed {c' : MixedColouring k ℓ ((m + m) + 2) // c'.IsEven}) ?_ ?_) ?_ · intro b _ hb - rw [if_neg (fun hspec => 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 [if_pos (peelColour_spec m c), mul_one] + · rw [ite_eq_left (peelColour_spec m c), mul_one] congr 1 rw [show evenBasisVec (⟨peelColour m c, peelColour_isEven m hc⟩ : @@ -109,7 +109,7 @@ theorem capVal_closed by_cases hfh : MixedColouring.IsEven (MixedColouring.firstHalf (a := m + m) (b := 2) (peelColour m c)) - · rw [dif_pos hfh] + · rw [dite_eq_left hfh] rw [show evenBasisVec (⟨peelColour m c, peelColour_isEven m hc⟩ : {c' : MixedColouring k ℓ @@ -124,14 +124,14 @@ theorem capVal_closed (peelColour m c).secondHalf_isEven (peelColour_isEven m hc) hfh⟩)) from by rw [evenBasisVec_split (peelColour m c) - (peelColour_isEven m hc), dif_pos hfh]] + (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 [dif_neg hfh] + · rw [dite_eq_right hfh] rw [show evenBasisVec (⟨peelColour m c, peelColour_isEven m hc⟩ : {c' : MixedColouring k ℓ @@ -151,7 +151,7 @@ theorem capVal_closed (superPow (stdSuperPair k ℓ) (m + m)) (superPow (stdSuperPair k ℓ) 2)).even) from by rw [evenBasisVec_split (peelColour m c) - (peelColour_isEven m hc), dif_neg hfh]] + (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 index 28b1b78b16..b3066de65f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapExpansion.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapExpansion.lean @@ -34,7 +34,7 @@ theorem capVal_expansion (m : ℕ) rw [show coordOf v c.val = (colourPowerEquiv k ℓ (m + m)).evenEquiv v c from by unfold coordOf - rw [dif_pos c.prop]] + 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 index 59617f9035..974177b0e1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapFun.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapFun.lean @@ -53,9 +53,9 @@ theorem omegaFun_cap_zero ((η P.ω : P.ω.obj (SkeinObj.mk 0) ⟶ SuperVect.tensorUnit) : SuperVect.Hom _ _).evenMap v := by - letI := P.braided + let := P.braided rw [bundleCapClass_zero] - show ((P.ω.map (𝟙 (SkeinObj.mk 0)) ≫ η P.ω : + 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)) = diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeel.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeel.lean index 79738892de..c2e75b1c65 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeel.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeel.lean @@ -43,12 +43,12 @@ def capPeelRotation (m : ℕ) : split_ifs <;> omega⟩ left_inv i := Fin.ext (by have := i.isLt - show capPeelInv m (capPeelFun m i.val) = i.val + change capPeelInv m (capPeelFun m i.val) = i.val unfold capPeelFun capPeelInv split_ifs <;> omega) right_inv j := Fin.ext (by have := j.isLt - show capPeelFun m (capPeelInv m j.val) = j.val + change capPeelFun m (capPeelInv m j.val) = j.val unfold capPeelFun capPeelInv split_ifs <;> omega) @@ -89,31 +89,31 @@ def capPeelFlagEquiv (m : ℕ) : obtain ⟨i, b⟩ := g unfold capPeelFlagFun by_cases h : i.val < m - · rw [dif_pos h] - show (⟨i.val, _⟩, b) = (i, b) + · rw [dite_eq_left h] + change (⟨i.val, _⟩, b) = (i, b) exact Prod.ext (Fin.ext rfl) rfl - · rw [dif_neg h] + · rw [dite_eq_right h] have hi : i.val = m := by have := i.isLt omega cases b - · show ((⟨m, _⟩ : Fin (m + 1)), + · 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 - · show ((⟨m, _⟩ : Fin (m + 1)), + · 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 - · show capPeelFlagFun m (⟨j.val, _⟩, b) = _ + · change capPeelFlagFun m (⟨j.val, _⟩, b) = _ unfold capPeelFlagFun - rw [dif_pos (show (⟨j.val, by omega⟩ : + rw [dite_eq_left (show (⟨j.val, by omega⟩ : Fin (m + 1)).val < m from j.isLt)] - · show capPeelFlagFun m (⟨m, _⟩, decide (t.val = 1)) = _ + · change capPeelFlagFun m (⟨m, _⟩, decide (t.val = 1)) = _ unfold capPeelFlagFun - rw [dif_neg (show ¬ ((⟨m, by omega⟩ : + rw [dite_eq_right (show ¬ ((⟨m, by omega⟩ : Fin (m + 1)).val < m) from by - show ¬ (m < m); omega)] + change ¬ (m < m); omega)] refine congrArg Sum.inr ?_ have ht := t.isLt rcases (show t.val = 0 ∨ t.val = 1 by omega) @@ -143,6 +143,267 @@ theorem capPeel_interleave_right_val (m X : ℕ) 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. -/ @@ -164,234 +425,8 @@ noncomputable def capPeelEquiv (m : ℕ) : show Empty ≃ (Empty ⊕ Empty) from _root_.Equiv.equivOfIsEmpty _ _ -- ═══════ ATTACHMENT ═══════ - attach_comm := fun g => 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) := dif_pos 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 - · show 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] - show capPeelInv m i.val = i.val - unfold capPeelInv - rw [if_pos h] - · show 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] - show 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 - show capPeelFlagFun m (i, false) = _ - unfold capPeelFlagFun - rw [dif_neg 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) ?_ - show 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] - show capPeelInv m ((m + m) + 0) = i.val - unfold capPeelInv - split_ifs <;> omega - · have hflag : capPeelFlagEquiv m (i, true) = - Sum.inr 1 := by - show capPeelFlagFun m (i, true) = _ - unfold capPeelFlagFun - rw [dif_neg 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) ?_ - show 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] - show capPeelInv m ((m + m) + 1) = (m + 1) + i.val - unfold capPeelInv - split_ifs <;> omega - -- ═══════ PAIRING ═══════ - pairing_comm := fun g => by - obtain ⟨i, b⟩ := g - show 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 ((dif_pos 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))) - (dif_pos 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 - show capPeelFlagFun m (i, false) = _ - unfold capPeelFlagFun - rw [dif_neg h] - rfl - have ht : capPeelFlagEquiv m (i, true) = - Sum.inr (1 : Fin 2) := by - show capPeelFlagFun m (i, true) = _ - unfold capPeelFlagFun - rw [dif_neg 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)) + attach_comm := capPeelEquiv_attach_comm m + pairing_comm := capPeelEquiv_pairing_comm m circles_eq := rfl variable {R : ℕ} (f : EdgeRankParameter R) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeelSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeelSplit.lean index 34c87fa66b..f269e2c6d5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeelSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeelSplit.lean @@ -71,7 +71,7 @@ theorem splitCapVal_expansion (m : ℕ) rw [show coordOf w c.val = (colourPowerEquiv k ℓ ((m + m) + 2)).evenEquiv w c from by unfold coordOf - rw [dif_pos c.prop]] + rw [dite_eq_left c.prop]] rfl /-- The split cap value on merges: `CapSplit` restated. -/ @@ -103,7 +103,7 @@ theorem splitCapVal_oddMerge (m : ℕ) (SuperVect.tensorObj (superPow (stdSuperPair k ℓ) (m + m)) (superPow (stdSuperPair k ℓ) 2)).even)) = 0 := by - letI := P.braided + let := P.braided have hmerge := congrArg (fun z : (superPow (stdSuperPair k ℓ) (m + m) ⊗ superPow (stdSuperPair k ℓ) 2 ⟶ @@ -119,7 +119,7 @@ theorem splitCapVal_oddMerge (m : ℕ) refine Eq.trans (congrArg (omegaFun f P (HomSpace.tensor f (m + m) 0 2 0 (bundleCapClass f m) (evClass f))) hmerge.symm) ?_ - show omegaFun f P (HomSpace.tensor f (m + m) 0 2 0 + 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 @@ -159,7 +159,7 @@ theorem capVal_succ (m : ℕ) eqToHom (congrArg (superPow (stdSuperPair k ℓ)) (capPeelArity m))) : SuperVect.Hom _ _).evenMap v) := by - letI := P.braided + let := P.braided have hchain : stdToOmega f P e ((m + 1) + (m + 1)) ≫ P.ω.map (bundleMapClass f (capPeelRotation m)) = (modelPermMap (capPeelPerm m) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPerm.lean index a08fc597e2..2292486d2d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPerm.lean @@ -58,7 +58,7 @@ theorem stdToOmega_bmc_cast {n₁ n₂ : ℕ} (h : n₁ = n₂) : P.ω.map (bundleMapClass f (finCongr h)) = eqToHom (congrArg (superPow (stdSuperPair k ℓ)) h) ≫ stdToOmega f P e n₂ := by - letI := P.braided + let := P.braided subst h rw [show (finCongr (rfl : n₁ = n₁) : Fin n₁ ≃ Fin n₁) = _root_.Equiv.refl (Fin n₁) from diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapSplit.lean index fb8a1d60b3..cf82cc7b4d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapSplit.lean @@ -41,7 +41,7 @@ theorem omegaFun_capTensor_merge (m : ℕ) omegaFun f P (evClass f) (((stdToOmega f P e 2) : SuperVect.Hom _ _).evenMap y) := by - letI := P.braided + let := P.braided -- The transported merge is the structure-map image of the -- blockwise transports. have hmerge := congrArg (fun z : @@ -53,7 +53,7 @@ theorem omegaFun_capTensor_merge (m : ℕ) refine Eq.trans (congrArg (omegaFun f P (HomSpace.tensor f (m + m) 0 2 0 (bundleCapClass f m) (evClass f))) hmerge.symm) ?_ - show omegaFun f P (HomSpace.tensor f (m + m) 0 2 0 + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapVal.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapVal.lean index 79802f1abe..9c32f9a4d7 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapVal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapVal.lean @@ -35,7 +35,7 @@ noncomputable def capVal (m : ℕ) /-- **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 - letI := P.braided + let := P.braided unfold capVal rw [omegaFun_cap_zero] have hcomp : (ε P.ω ≫ η P.ω : SuperVect.tensorUnit ⟶ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ChainLists.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ChainLists.lean index 0d4d17a310..4ebb0efdea 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ChainLists.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ChainLists.lean @@ -16,7 +16,7 @@ the global pair concatenation. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleModel.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleModel.lean index e7e922fad4..f591853d9c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleModel.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleModel.lean @@ -74,7 +74,7 @@ theorem coev_comp_ev : ε_ (SkeinObj.mk 1) (SkeinObj.mk 1) : (SkeinObj.mk 0 : SkeinObj f) ⟶ SkeinObj.mk 0) = circleVal f • 𝟙 (SkeinObj.mk 0) := by - show HomSpace.comp f 0 2 0 (coevClass f) (evClass f) = _ + 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) = @@ -109,7 +109,7 @@ theorem circleVal_model {k ℓ : ℕ} δ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1)) = stdCopair k ℓ) : circleVal f = (k : ℂ) - 2 * ℓ := by - letI := P.braided + 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) ≫ @@ -129,7 +129,7 @@ theorem circleVal_model {k ℓ : ℕ} rw [show (ε P.ω ≫ η P.ω : SuperVect.tensorUnit ⟶ SuperVect.tensorUnit) = 𝟙 _ from Functor.Monoidal.ε_η P.ω] - show circleVal f * 1 = circleVal f + change circleVal f * 1 = circleVal f ring -- The same scalar through the standard model. have hsplit : ((ε P.ω ≫ P.ω.map diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleScalar.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleScalar.lean index 725f761ac6..d0d1261a97 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleScalar.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleScalar.lean @@ -42,7 +42,7 @@ noncomputable def addCirclesTensor {s t : ℕ} _root_.Equiv.sumEmpty X.Vertex Empty attach_comm := fun g => by rcases g with g | g - · show (X.attach g).map id + · 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 @@ -85,15 +85,15 @@ noncomputable def circlesClosedUnion (a b : ℕ) : inferInstanceAs (IsEmpty Empty) _root_.Equiv.equivOfIsEmpty _ _ attach_comm := fun g => by - haveI h1 : IsEmpty (circlesClosed a).Flag := + have h1 : IsEmpty (circlesClosed a).Flag := inferInstanceAs (IsEmpty Empty) - haveI h2 : IsEmpty (circlesClosed b).Flag := + have h2 : IsEmpty (circlesClosed b).Flag := inferInstanceAs (IsEmpty Empty) exact g.elim h1.elim h2.elim pairing_comm := fun g => by - haveI h1 : IsEmpty (circlesClosed a).Flag := + have h1 : IsEmpty (circlesClosed a).Flag := inferInstanceAs (IsEmpty Empty) - haveI h2 : IsEmpty (circlesClosed b).Flag := + have h2 : IsEmpty (circlesClosed b).Flag := inferInstanceAs (IsEmpty Empty) exact g.elim h1.elim h2.elim circles_eq := rfl @@ -119,11 +119,11 @@ theorem circlesClosed_val {R : ℕ} (f : EdgeRankParameter R) inferInstanceAs (IsEmpty Empty) _root_.Equiv.equivOfIsEmpty _ _ attach_comm := fun g => by - haveI : IsEmpty (circlesClosed 0).Flag := + have : IsEmpty (circlesClosed 0).Flag := inferInstanceAs (IsEmpty Empty) exact isEmptyElim g pairing_comm := fun g => by - haveI : IsEmpty (circlesClosed 0).Flag := + have : IsEmpty (circlesClosed 0).Flag := inferInstanceAs (IsEmpty Empty) exact isEmptyElim g circles_eq := rfl } diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ConcatSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ConcatSign.lean index e1b18f1f8d..b910643979 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ConcatSign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ConcatSign.lean @@ -16,7 +16,7 @@ blocks are disjoint and ordered, so concatenation adds no inversions. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} @@ -111,6 +111,7 @@ theorem sortKey_mem_block (W : ClosedFragment) (F : EdgeSubset W) (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 @@ -138,7 +139,7 @@ theorem globalPairList_nodup (W : ClosedFragment) · have hpw : (List.finRange (ds W).length).Pairwise (· < ·) := (List.sortedLT_finRange _).pairwise exact hpw.imp (fun {v₁ v₂} hlt => by - show List.Disjoint _ _ + 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₂ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordInterface.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordInterface.lean index a313e3b82b..506da59e93 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordInterface.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordInterface.lean @@ -57,7 +57,7 @@ theorem omega_pairing {d : ℕ} theorem star_pairing (W : ClosedFragment) : omegaFun f P (bundleCapClass f (edgeCount W)) (omegaVec f P (starClass f W)) = f.val W := by - letI := P.braided + let := P.braided rw [← omega_pairing] exact omega_star_scalar f P W diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordOf.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordOf.lean index 6bc526a711..0fe6aaddcc 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordOf.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordOf.lean @@ -32,7 +32,7 @@ theorem coordOf_odd {n : ℕ} (v : (superPow (stdSuperPair k ℓ) n).even) (c : MixedColouring k ℓ n) (hc : ¬ c.IsEven) : coordOf v c = 0 := - dif_neg hc + dite_eq_right hc /-- The cast rule: coordinates of a recast vector read the recast colouring. -/ @@ -57,7 +57,7 @@ theorem toColour_apply {n : ℕ} ((colourPowerEquiv k ℓ n).evenEquiv v) = (colourPowerEquiv k ℓ n).evenEquiv ((g : SuperVect.Hom _ _).evenMap v) := by - show (colourPowerEquiv k ℓ n).evenEquiv + change (colourPowerEquiv k ℓ n).evenEquiv ((g : SuperVect.Hom _ _).evenMap ((colourPowerEquiv k ℓ n).evenEquiv.symm ((colourPowerEquiv k ℓ n).evenEquiv v))) = _ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoreParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoreParity.lean index f8076d739a..35554a8efd 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoreParity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoreParity.lean @@ -24,7 +24,7 @@ namespace RS open CategoryTheory MonoidalCategory Finset open Functor.LaxMonoidal Functor.OplaxMonoidal -open Classical + variable {R : ℕ} (f : EdgeRankParameter R) variable (P : DelignePackage (SkeinObj f)) @@ -32,6 +32,72 @@ 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. -/ @@ -120,62 +186,7 @@ theorem core_parity (W : ClosedFragment) have hMD := sign_listIndexPerm_matched_global W F o -- ═══════ STAGE 3: THE FLAG-COUNT BRIDGE ═══════ -- the flag-count bridge - 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 nB - 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 + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EdgeSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EdgeSign.lean index fd06f26745..8bbe3fd356 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EdgeSign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EdgeSign.lean @@ -17,7 +17,7 @@ count of edges whose representative is incoming. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} @@ -90,7 +90,7 @@ theorem edge_sign_sector (W : ClosedFragment) set g := (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i) with hg by_cases h : g ∈ F.flags - · rw [dif_pos h, dif_pos h] + · 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 @@ -98,7 +98,7 @@ theorem edge_sign_sector (W : ClosedFragment) exact hout) rw [EdgeSubset.OddColouring.flip_val_mem F _ _ φ ⟨g, h⟩ hT, oddPartnerSign_oddPartner] - rw [if_neg (by + rw [ite_eq_right (by rintro ⟨-, hfalse⟩ rw [hout] at hfalse exact Bool.noConfusion hfalse)] @@ -114,10 +114,10 @@ theorem edge_sign_sector (W : ClosedFragment) exact Bool.noConfusion h2 rw [EdgeSubset.OddColouring.flip_val_not_mem F _ _ φ ⟨g, h⟩ hT] - rw [if_pos ⟨h, hof⟩] + rw [ite_eq_left ⟨h, hof⟩] ring - · rw [dif_neg h, dif_neg h, - if_neg (fun hmem => h hmem.1), one_mul] + · 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvForm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvForm.lean index 7cada6867e..f171b4d9f2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvForm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvForm.lean @@ -40,12 +40,12 @@ theorem evForm SuperVect.Hom _ _).evenMap (evenPair (e.evenMap x) (e.evenMap y))) = (stdForm k ℓ).evenMap (evenPair x y) := by - letI := P.braided + 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 - show omegaFun f P (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) + 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))) = diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvFormOdd.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvFormOdd.lean index c1eadd4a11..f55cf9de9d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvFormOdd.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvFormOdd.lean @@ -43,12 +43,12 @@ theorem evFormOdd SuperVect.Hom _ _).evenMap (oddPair (e.oddMap x) (e.oddMap y))) = (stdForm k ℓ).evenMap (oddPair x y) := by - letI := P.braided + 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 - show omegaFun f P (ε_ (SkeinObj.mk 1) (SkeinObj.mk 1)) + 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))) = diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvLeaf.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvLeaf.lean index ced44ed342..8f99648894 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvLeaf.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvLeaf.lean @@ -29,7 +29,7 @@ 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 - show LinearMap.coprod + change LinearMap.coprod (TensorProduct.lift (stdFormEvenBilin k)) (TensorProduct.lift (stdFormOddBilin ℓ)) (x ⊗ₜ[ℂ] y, 0) = _ @@ -39,7 +39,7 @@ theorem stdForm_evenPair (x y : (stdSuperPair k ℓ).even) : /-- 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 - show LinearMap.coprod + change LinearMap.coprod (TensorProduct.lift (stdFormEvenBilin k)) (TensorProduct.lift (stdFormOddBilin ℓ)) (0, x ⊗ₜ[ℂ] y) = _ @@ -67,7 +67,7 @@ theorem omegaFun_ev_basis (evenBasisVec (⟨c, hc⟩ : {c : MixedColouring k ℓ 2 // c.IsEven}))) = colourFormEntry k ℓ (c 0) (c 1) := by - letI := P.braided + 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. @@ -84,7 +84,7 @@ theorem omegaFun_ev_basis have hfe : MixedColouring.IsEven (MixedColouring.firstHalf (a := 1) (b := 1) c) := by rw [hfh]; exact oneColourE_isEven i - rw [hsplit, dif_pos hfe] + 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 @@ -112,7 +112,7 @@ theorem omegaFun_ev_basis (stdToOmega_merge f P e 1 1) refine Eq.trans (congrArg (omegaFun f P (evClass f)) hmerge.symm) ?_ - show omegaFun f P (evClass f) + 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) : @@ -160,7 +160,7 @@ theorem omegaFun_ev_basis have hfo : ¬ MixedColouring.IsEven (MixedColouring.firstHalf (a := 1) (b := 1) c) := by rw [hfh]; exact oneColourO_not_isEven a - rw [hsplit, dif_neg hfo] + 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 @@ -188,7 +188,7 @@ theorem omegaFun_ev_basis (stdToOmega_merge f P e 1 1) refine Eq.trans (congrArg (omegaFun f P (evClass f)) hmerge.symm) ?_ - show omegaFun f P (evClass f) + 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) : diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FibreParam.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FibreParam.lean index 0dc16f9d2c..6c41339807 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FibreParam.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FibreParam.lean @@ -17,7 +17,7 @@ partner on the partner slot; the rest carry the even colour. namespace RS open CategoryTheory Finset -open Classical + variable {k ℓ : ℕ} @@ -48,14 +48,14 @@ theorem colourFlags_colouringOf (W : ClosedFragment) obtain ⟨-, hodd⟩ := hs by_contra hnot rw [colouringOf] at hodd - rw [dif_neg hnot] 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 [dif_pos (show (starFlagEnum W).symm + rw [dite_eq_left (show (starFlagEnum W).symm (starFlagEnum W g) ∈ F.flags from by rw [Equiv.symm_apply_apply]; exact hg)] rfl @@ -152,13 +152,13 @@ theorem colouringOf_diagonal (W : ClosedFragment) (Fin.natAdd (edgeCount W) i) ∈ F.flags := by rw [hpair] exact F.pairing_mem _ h - rw [dif_pos h, dif_pos h'] - rw [if_pos (show (Fin.castAdd (edgeCount W) i).val < + 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 [if_neg (show ¬ ((Fin.natAdd (edgeCount W) i).val < + rw [ite_eq_right (show ¬ ((Fin.natAdd (edgeCount W) i).val < edgeCount W) from by - show ¬ (edgeCount W + i.val < edgeCount W); omega)] - show Sum.inr (oddPartner ℓ (φ.val ⟨_, h'⟩)) = + 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'⟩ = @@ -180,8 +180,8 @@ theorem colouringOf_diagonal (W : ClosedFragment) have := F.pairing_mem _ hmem rw [W.pairing_invol] at this exact this - rw [dif_neg h, dif_neg h'] - show Sum.inl (ψ.val ⟨_, h'⟩) = + 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'⟩ = @@ -301,7 +301,7 @@ theorem starFlagEnum_pairing_high (W : ClosedFragment) (Fin.natAdd (edgeCount W) j) := by rw [show Fin.natAdd (edgeCount W) j = starFlagEnum W g from Fin.ext (by - show edgeCount W + ((starFlagEnum W g).val - + change edgeCount W + ((starFlagEnum W g).val - edgeCount W) = (starFlagEnum W g).val omega)] exact (_root_.Equiv.symm_apply_apply _ _).symm @@ -328,20 +328,20 @@ theorem oddDataOf_constancy (W : ClosedFragment) obtain ⟨g, hg⟩ := p rw [oddDataOf, oddDataOf] by_cases hlow : (starFlagEnum W g).val < edgeCount W - · rw [if_pos hlow] - rw [if_neg (show ¬ ((starFlagEnum 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] - show ¬ (edgeCount W + (starFlagEnum W g).val < + change ¬ (edgeCount W + (starFlagEnum W g).val < edgeCount W) omega)] exact getRight_congr (congrArg c (congrArg _ (W.pairing_invol g))) _ _ - · rw [if_neg hlow] - rw [if_pos (show (starFlagEnum W + · 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] - show (starFlagEnum W g).val - edgeCount W < + change (starFlagEnum W g).val - edgeCount W < edgeCount W have := (starFlagEnum W g).isLt; omega)] @@ -379,7 +379,7 @@ theorem evenDataOf_constancy (W : ClosedFragment) · have hlow' : (starFlagEnum W (W.pairing g)).val < edgeCount W := by rw [starFlagEnum_pairing_high W g hlow] - show (starFlagEnum W g).val - edgeCount W < + change (starFlagEnum W g).val - edgeCount W < edgeCount W have := (starFlagEnum W g).isLt; omega have hpart := hdiag ⟨(starFlagEnum W @@ -440,27 +440,27 @@ theorem colouringOf_reconstruct (W : ClosedFragment) slot := _root_.Equiv.apply_symm_apply _ _ rw [colouringOf] by_cases h : (starFlagEnum W).symm slot ∈ F.flags - · rw [dif_pos h] + · 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 [if_pos hrep] - show Sum.inr (oddDataOf W F c hfibre + · rw [ite_eq_left hrep] + change Sum.inr (oddDataOf W F c hfibre ⟨(starFlagEnum W).symm slot, h⟩) = c slot rw [oddDataOf] - rw [if_pos (show (starFlagEnum W + 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 [if_neg hrep] - show Sum.inr (oddPartner ℓ (oddDataOf W F c hfibre + · rw [ite_eq_right hrep] + change Sum.inr (oddPartner ℓ (oddDataOf W F c hfibre ⟨(starFlagEnum W).symm slot, h⟩)) = c slot rw [oddDataOf] - rw [if_neg (show ¬ ((starFlagEnum W + 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) := @@ -473,13 +473,13 @@ theorem colouringOf_reconstruct (W : ClosedFragment) (by rw [henum]; exact hrep)) ?_ refine congrArg (Fin.castAdd (edgeCount W)) ?_ refine Fin.ext ?_ - show (starFlagEnum W + 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 - show edgeCount W + (slot.val - edgeCount W) = + change edgeCount W + (slot.val - edgeCount W) = slot.val omega) have hd := hdiag i₀ @@ -508,7 +508,7 @@ theorem colouringOf_reconstruct (W : ClosedFragment) getRight_congr hu hrepodd rfl] rw [hd, hu] rfl - · rw [dif_neg h] + · rw [dite_eq_right h] have hnotodd : ¬ ((c slot).isRight = true) := by have hm : ¬ ((starFlagEnum W).symm slot ∈ colourFlags W c) := by @@ -519,7 +519,7 @@ theorem colouringOf_reconstruct (W : ClosedFragment) rcases hx : c slot with a | u · rfl · exact absurd (by rw [hx]; rfl) hnotodd - show Sum.inl (evenDataOf W F c hfibre + 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)) @@ -540,34 +540,34 @@ theorem oddColouringOf_colouringOf (W : ClosedFragment) · exact hgoal rw [oddDataOf] by_cases hlow : (starFlagEnum W g).val < edgeCount W - · rw [if_pos hlow] + · rw [ite_eq_left hlow] have hval : colouringOf W F ψ φ (starFlagEnum W g) = Sum.inr (φ.val ⟨g, hg⟩) := by rw [colouringOf] - rw [dif_pos (show (starFlagEnum W).symm + rw [dite_eq_left (show (starFlagEnum W).symm (starFlagEnum W g) ∈ F.flags from by rw [_root_.Equiv.symm_apply_apply]; exact hg)] - rw [if_pos hlow] + 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 [if_neg hlow] + · rw [ite_eq_right hlow] have hglow : (starFlagEnum W (W.pairing g)).val < edgeCount W := by rw [starFlagEnum_pairing_high W g hlow] - show (starFlagEnum W g).val - edgeCount W < + 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 [dif_pos (show (starFlagEnum W).symm + 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 [if_pos hglow] + rw [ite_eq_left hglow] refine congrArg Sum.inr ?_ refine Eq.trans (congrArg φ.val (show (⟨(starFlagEnum W).symm (starFlagEnum W @@ -598,7 +598,7 @@ theorem evenColouringOf_colouringOf (W : ClosedFragment) have hval : colouringOf W F ψ φ (starFlagEnum W g) = Sum.inl (ψ.val ⟨g, hg⟩) := by rw [colouringOf] - rw [dif_neg (show ¬ ((starFlagEnum W).symm + 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 ?_ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FlagEnum.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FlagEnum.lean index 57ca6b9295..579219ce21 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FlagEnum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FlagEnum.lean @@ -17,7 +17,7 @@ the raw material for the canonical index permutation between them. namespace RS -open Classical Finset +open Finset section PairSide @@ -43,8 +43,8 @@ theorem mem_pairBase {o : κ.Orientation} {v : W.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 - letI := W.flagOrder - letI := Classical.dec + let := W.flagOrder + let := Classical.dec unfold EdgeSubset.inFlagsAt at hf exact (Finset.mem_filter.mp ((Finset.mem_sort _).mp hf)).2.1 @@ -65,8 +65,8 @@ theorem pairFlagList_nodup (o : κ.Orientation) (v : W.Vertex) : (fun _ hf' => F.mem_of_mem_inFlagsAt hf')).Nodup := by refine List.Nodup.pmap (fun a _ b _ h => congrArg Subtype.val h) ?_ - letI := W.flagOrder - letI := Classical.dec + let := W.flagOrder + let := Classical.dec exact Finset.sort_nodup _ _ refine List.Pairwise.imp_of_mem ?_ (List.Pairwise.imp (fun {a b} h => h) @@ -128,7 +128,7 @@ theorem mem_pairFlagList (o : κ.Orientation) (v : W.Vertex) · 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 - show o.isOut (κ.match_ x.val) = false + 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 := @@ -146,7 +146,7 @@ theorem mem_pairFlagList (o : κ.Orientation) (v : W.Vertex) · refine List.mem_cons.mpr (Or.inr ?_) rw [List.mem_singleton] refine Subtype.ext ?_ - show x.val = κ.match_ f₀.val + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/GlobalSlotList.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/GlobalSlotList.lean index 602310a1ab..c6bac7ba31 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/GlobalSlotList.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/GlobalSlotList.lean @@ -16,7 +16,7 @@ and the link between the pattern inversion count and list inversions. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} @@ -63,7 +63,7 @@ theorem mem_globalSlotList (W : ClosedFragment) (F : EdgeSubset W) Subtype.ext (_root_.Equiv.symm_apply_apply _ _)⟩ /-- Filter length of `ofFn` matches finset card. -/ -theorem filter_length_ofFn {β : Type} [DecidableEq β] +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 @@ -82,11 +82,12 @@ theorem filter_length_ofFn {β : Type} [DecidableEq β] /-- Helper: the head-filter count in the successor step. -/ private theorem head_filter_card {β : Type} [LinearOrder β] - [DecidableEq β] {n : ℕ} (g : Fin (n + 1) → β) : + {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 @@ -381,7 +382,7 @@ private theorem sort_getElem_slotPos (W : ClosedFragment) 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.getElem?_inj hi hnd).mp + 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) @@ -497,13 +498,13 @@ private theorem inversions_eq_slotInvPairs (W : ClosedFragment) · 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 - show ((globalSlotList W F)[i.val]'hi_lt).val = _ + 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 - show ((globalSlotList W F)[j.val]'hj_lt).val = _ + change ((globalSlotList W F)[j.val]'hj_lt).val = _ rw [globalSlotList_getElem_val] congr 1 exact sort_getElem_slotPos W F q₂ hq2 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/HRS.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/HRS.lean index 660065d192..00207792a5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/HRS.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/HRS.lean @@ -40,7 +40,7 @@ noncomputable def starCoord (d : ℕ) /-- 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 := - dif_neg hc + dite_eq_right hc /-- **The Regts–Sevenster functional**: the star coordinate at the canonical colouring, the paper's witness `h^ξ` (§5.4). -/ @@ -56,6 +56,6 @@ theorem evalOdd_hRS_nodup (μm : Multiset (Fin k)) starCoord f P e' (μm.card + w.toFinset.card) (canonColouring μm w.toFinset) := by unfold MixedFunctional.evalOdd hRS - rw [if_pos hw] + 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 index 350619b4a1..be7d835ee5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/IndexPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/IndexPerm.lean @@ -25,7 +25,7 @@ open Equiv /-- Duplicate-free lists with the same members have the same length. -/ -theorem length_eq_of_nodup_mem {γ : Type*} [DecidableEq γ] (l₁ l₂ : List γ) +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 @@ -150,7 +150,7 @@ theorem sign_listIndexPerm_trans {γ : Type*} [DecidableEq γ] -- element l₁[i] in l₃. simp only [Perm.mul_apply] -- Unfold τ₂₃' to finCongr ∘ τ₂₃ ∘ finCongr - show τ₁₃ i = (finCongr hlen₁₂).symm (τ₂₃ ((finCongr hlen₁₂) (τ₁₂ i))) + 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] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelCoord.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelCoord.lean index 318019c4a8..64e373a7b3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelCoord.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelCoord.lean @@ -67,14 +67,14 @@ theorem coordOf_modelStarVec : ∏ v : Fin ds.length, starCoord f P e' (ds.get v) (blockRestrict ds c v) | [], c, hc => by - haveI : IsEmpty (Fin ([] : List ℕ).length) := + 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 [dif_pos hc] + rw [dite_eq_left hc] rfl | d :: ds, c, hc => by -- Push through the cast. @@ -94,7 +94,7 @@ theorem coordOf_modelStarVec : (List.sum_cons.symm : d + ds.sum = (d :: ds).sum)) := (isEven_comp_finCongr _ c).mpr hc unfold coordOf - rw [dif_pos hc'] + 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) @@ -110,7 +110,7 @@ theorem coordOf_modelStarVec : (MixedColouring.firstHalf ((c ∘ finCongr (List.sum_cons.symm : d + ds.sum = (d :: ds).sum)) : MixedColouring k ℓ (d + ds.sum))) - · rw [dif_pos hfe] + · rw [dite_eq_left hfe] -- Head factor is the star coordinate. rw [show ((colourPowerEquiv k ℓ d).evenEquiv (((stdFromOmega f P e' d) : @@ -123,7 +123,7 @@ theorem coordOf_modelStarVec : ⟨0, by simp⟩) from by rw [blockRestrict_cons_head] unfold starCoord - rw [dif_pos hfe]] + rw [dite_eq_left hfe]] -- Tail factor is the induction. rw [show ((colourPowerEquiv k ℓ ds.sum).evenEquiv (modelStarVec f P e' ds) @@ -137,7 +137,7 @@ theorem coordOf_modelStarVec : d + ds.sum = (d :: ds).sum)) : MixedColouring k ℓ (d + ds.sum))) from by unfold coordOf - rw [dif_pos (MixedColouring.secondHalf_isEven _ + rw [dite_eq_left (MixedColouring.secondHalf_isEven _ hc' hfe)]] rw [coordOf_modelStarVec ds _ (MixedColouring.secondHalf_isEven _ hc' hfe)] @@ -145,7 +145,7 @@ theorem coordOf_modelStarVec : refine Finset.prod_congr rfl (fun v _ => ?_) rw [blockRestrict_cons_tail] rfl - · rw [dif_neg hfe] + · 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelPermCoord.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelPermCoord.lean index 43b68efe72..ae323d549b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelPermCoord.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelPermCoord.lean @@ -27,7 +27,7 @@ theorem wordPerm_eq_prod {n : ℕ} (w : List (Fin n)) : induction w with | nil => rfl | cons i w ih => - show _root_.Equiv.swap _ _ * wordPerm w = _ + change _root_.Equiv.swap _ _ * wordPerm w = _ rw [List.map_cons, List.prod_cons, ih] rfl @@ -52,7 +52,7 @@ theorem coordOf_modelPermMap {n : ℕ} (colourPowerEquiv k ℓ (n + 1)).evenEquiv (((modelPermMap σ) : SuperVect.Hom _ _).evenMap v) ⟨c, hc⟩ from by - unfold coordOf; rw [dif_pos hc]] + unfold coordOf; rw [dite_eq_left hc]] rw [← toColour_apply] rw [show modelPermMap σ = powBraidWord (stdSuperPair k ℓ) (adjWord σ) from rfl] @@ -62,7 +62,7 @@ theorem coordOf_modelPermMap {n : ℕ} rw [show coordOf v (c ∘ σ) = (colourPowerEquiv k ℓ (n + 1)).evenEquiv v ⟨c ∘ σ, hc.comp σ⟩ from by - unfold coordOf; rw [dif_pos (hc.comp σ)]] + unfold coordOf; rw [dite_eq_left (hc.comp σ)]] · rw [coordOf_odd _ _ hc] have hcσ : ¬ MixedColouring.IsEven (c ∘ σ) := fun he => hc (by diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelStarVec.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelStarVec.lean index 092c02ccdf..caffa3895c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelStarVec.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelStarVec.lean @@ -58,7 +58,7 @@ theorem stdToOmega_modelStarVec (modelStarVec f P e' ds) = omegaStarVec f P ds | [] => by - letI := P.braided + let := P.braided exact congrArg (fun z : (SuperVect.tensorUnit ⟶ P.ω.obj (SkeinObj.mk 0)) => (z : SuperVect.Hom _ _).evenMap (1 : ℂ)) @@ -66,7 +66,7 @@ theorem stdToOmega_modelStarVec (congrArg (fun w => ε P.ω ≫ w) (P.ω.map_id (SkeinObj.mk 0)).symm)) | d :: ds => by - letI := P.braided + 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) @@ -100,7 +100,7 @@ theorem stdToOmega_modelStarVec · rfl · -- Evaluate the tensor on the even pair, cancel the -- strand inverse, and use the induction. - show (P.ω.map (bundleMapClass f (finCongr + 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)) : diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MultiStar.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MultiStar.lean index 1728dd702a..928f12db00 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MultiStar.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MultiStar.lean @@ -63,16 +63,16 @@ noncomputable def starUnionMultiStar (W : ClosedFragment) : vertexEquiv := _root_.Equiv.refl W.Vertex attach_comm := fun g => by rcases g with fo | fc - · show Sum.inl (starAssign W (starFlagEnum W fo)) = + · 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 ?_ - show ClosedFragment.vertexOf W + change ClosedFragment.vertexOf W ((starFlagEnum W).symm (starFlagEnum W fo)) = _ rw [(starFlagEnum W).symm_apply_apply] rfl - · show Sum.inr (starEnum W fc) = + · 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 @@ -81,12 +81,12 @@ noncomputable def starUnionMultiStar (W : ClosedFragment) : rcases g with fo | fc · have hp : (starUnion W).pairing (Sum.inl fo) = Sum.inr ⟨fo, Finset.mem_univ fo⟩ := - dif_pos (Finset.mem_univ fo) + dite_eq_left (Finset.mem_univ fo) rw [hp] - show Sum.inr (starEnum W ⟨fo, Finset.mem_univ fo⟩) = + change Sum.inr (starEnum W ⟨fo, Finset.mem_univ fo⟩) = Sum.inr (starFlagEnum W fo) rfl - · show Sum.inl (starFlagEnum W fc.val) = + · change Sum.inl (starFlagEnum W fc.val) = Sum.inl ((starFlagEnum W).symm.symm fc.val) rfl circles_eq := rfl diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFDef.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFDef.lean index 9f79395b29..ea13af0a0a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFDef.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFDef.lean @@ -20,7 +20,7 @@ transition system and orientation. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} @@ -88,10 +88,10 @@ theorem hMaster_vertex_nodup (h : MixedFunctional k ℓ) 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 [if_pos hnd_b] + rw [ite_eq_left hnd_b] rw [evenMultisetOf_blockRestrict W F o ψ φ v] rw [oddFinsetOf_blockRestrict W F o ψ φ v] - rw [MixedFunctional.evalOdd, if_pos hnd] + 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)) : ℂ) @@ -124,7 +124,7 @@ theorem hMaster_vertex_not_nodup (h : MixedFunctional k ℓ) (cSorted W (colouringOfFlip W F o ψ φ)) v)).Nodup := fun hn => hnd ((oddListOf_blockRestrict_nodup_iff W F o ψ φ v).mp hn) - exact if_neg hnd_b + exact ite_eq_right hnd_b /-! ## The normal form -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFValue.lean index 8601b001ff..b17a500e54 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFValue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFValue.lean @@ -17,7 +17,7 @@ independence. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} @@ -255,7 +255,7 @@ theorem mixedValue_eq_summand_closed {κ : F.TransitionSystem} (o : κ.Orientation) : F.mixedValue h = F.mixedSummand h o := by have hne : Nonempty ((κ' : F.TransitionSystem) × κ'.Orientation) := ⟨⟨κ, o⟩⟩ - rw [EdgeSubset.mixedValue, dif_pos hne] + 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 index 07bc2c37f8..443837f72e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddFlip.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddFlip.lean @@ -80,8 +80,8 @@ theorem EdgeSubset.OddColouring.flip_val_mem (φ : 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 - show (if f.val ∈ T then oddPartner ℓ (φ.val f) else φ.val f) = _ - exact if_pos h + 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`. -/ @@ -90,7 +90,7 @@ theorem EdgeSubset.OddColouring.flip_val_not_mem (φ : F.OddColouring ℓ) (f : {f : W.Flag // f ∈ F.flags}) (h : f.val ∉ T) : (EdgeSubset.OddColouring.flip F T hT φ).val f = φ.val f := by - show (if f.val ∈ T then oddPartner ℓ (φ.val f) else φ.val f) = _ - exact if_neg h + 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 index 2119f0034f..ca01bef6cb 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddListMultiset.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddListMultiset.lean @@ -18,8 +18,7 @@ compared, since only the order distinguishes them. namespace RS -open Finset Classical - +open Finset variable {α : Type} {W : Fragment α} {F : EdgeSubset W} {ℓ : ℕ} {κ : F.TransitionSystem} @@ -43,6 +42,7 @@ private theorem multiset_bind_pair {β γ : Type} (m : Multiset β) /-! ### 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 @@ -52,8 +52,8 @@ theorem attachWith_sort_eq_filter_val 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 - letI := W.flagOrder - letI := Classical.dec + 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 := @@ -117,6 +117,7 @@ private theorem match_maps_out_to_in (o : κ.Orientation) (v : W.Vertex) 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) : @@ -140,6 +141,7 @@ private theorem match_image_in_eq_out (o : κ.Orientation) (v : W.Vertex) : /-! ### 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 = @@ -175,6 +177,7 @@ private theorem filter_at_v_split (o : κ.Orientation) (v : W.Vertex) : /-! ### 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 ℓ) @@ -210,8 +213,8 @@ theorem oddListAt_coe_multiset (o : κ.Orientation) (φ : F.OddColouring ℓ) -- As multisets: ↑[a, b] = a ::ₘ b ::ₘ 0 = {a} + {b} let a := φ.val ⟨f, hf⟩ let b := oddPartner ℓ (φ.val ⟨κ.match_ f, κ.match_mem _ hf⟩) - show (↑(F.oddPairFn κ φ ⟨f, hf⟩) : Multiset _) = ({a} : Multiset _) + {b} - show (↑([a, b] : List _) : Multiset _) = ({a} : Multiset _) + {b} + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddPair.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddPair.lean index 8902234f0c..07c4bf6cdc 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddPair.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddPair.lean @@ -33,8 +33,8 @@ theorem tensorHom_oddPair {V₁ V₂ W₁ W₂ : SuperVect} SuperVect.Hom _ _).evenMap (oddPair v w) = oddPair ((g : SuperVect.Hom _ _).oddMap v) ((h : SuperVect.Hom _ _).oddMap w) := by - show (SuperVect.tensorHom g h).evenMap (oddPair v w) = _ - show ((TensorProduct.map (g : SuperVect.Hom _ _).evenMap + 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)) = _ @@ -49,7 +49,7 @@ theorem lambda_oddPair SuperVect.tensorObj SuperVect.tensorUnit SuperVect.tensorUnit ⟶ SuperVect.tensorUnit) : SuperVect.Hom _ _).evenMap (oddPair v w) = 0 := by - show (TensorProduct.lid ℂ ℂ).toLinearMap + change (TensorProduct.lid ℂ ℂ).toLinearMap ((LinearMap.fst ℂ _ _) (oddPair v w)) = 0 rw [show (LinearMap.fst ℂ _ _) (oddPair v w) = (0 : ℂ ⊗[ℂ] ℂ) from rfl] @@ -72,7 +72,7 @@ theorem omegaFun_tensor_oddPair {a b : ℕ} omegaFun f P (q₁ ⊗ₘ q₂) (((μ P.ω (SkeinObj.mk a) (SkeinObj.mk b)) : SuperVect.Hom _ _).evenMap (oddPair v w)) = 0 := by - letI := P.braided + let := P.braided have hhom : (λ_ (𝟙_ (SkeinObj f))).hom = 𝟙 (𝟙_ (SkeinObj f)) := by have h1 := Iso.hom_inv_id (λ_ (𝟙_ (SkeinObj f))) @@ -92,12 +92,12 @@ theorem omegaFun_tensor_oddPair {a b : ℕ} (z : SuperVect.Hom _ _).evenMap (oddPair v w)) habs refine Eq.trans ?_ (Eq.trans hev ?_) · rfl - · show ((((P.ω.map q₁ ≫ η P.ω) ⊗ₘ (P.ω.map q₂ ≫ η P.ω)) ≫ + · 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 - show (((λ_ (𝟙_ SuperVect)).hom : + change (((λ_ (𝟙_ SuperVect)).hom : SuperVect.tensorObj SuperVect.tensorUnit SuperVect.tensorUnit ⟶ SuperVect.tensorUnit) : SuperVect.Hom _ _).evenMap diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean index fc88e5641e..b7d53bb8b0 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean @@ -12,8 +12,7 @@ import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists namespace RS -open Finset Classical - +open Finset variable {α : Type} {W : Fragment α} {F : EdgeSubset W} {ℓ : ℕ} {κ : F.TransitionSystem} @@ -28,7 +27,7 @@ private noncomputable def EdgeSubset.oddSignFn' (F : EdgeSubset W) 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 dif_pos hf + unfold EdgeSubset.oddSignFn'; exact dite_eq_left hf /-- The attachWith-map list equals a plain map with classically lifted function. -/ @@ -46,6 +45,7 @@ private theorem EdgeSubset.attachWith_map_oddSignFn_eq (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) : @@ -53,7 +53,7 @@ private theorem EdgeSubset.inFlagsAt_perm_filter_toList ((F.flags.filter (fun f => W.attach f = Sum.inl v ∧ o.isOut f = false)).toList) := by unfold EdgeSubset.inFlagsAt - letI := W.flagOrder + 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 @@ -67,6 +67,7 @@ private theorem EdgeSubset.inFlagsAt_perm_filter_toList /-! ### 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 @@ -98,6 +99,7 @@ private theorem EdgeSubset.prod_oddSignAt_eq_prod_flags_incoming ∏ 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 @@ -117,7 +119,7 @@ private theorem EdgeSubset.prod_oddSignAt_eq_prod_flags_incoming exact hv (Sum.inl.inj (hatt ▸ hvf)) simp [this] · have hone : F.oddSignFn' κ φ f = 1 := by - unfold EdgeSubset.oddSignFn'; rw [dif_neg hf] + unfold EdgeSubset.oddSignFn'; rw [dite_eq_right hf] simp [hone] /-! ### Step 3: incoming to subtype, then reindex -/ @@ -146,7 +148,7 @@ theorem prod_oddSignAt (o : κ.Orientation) (φ : F.OddColouring ℓ) : congr 1; ext f simp only [e, Equiv.coe_fn_mk] rw [o.match_flip _ f.prop] - cases hb : o.isOut f.val <;> simp + cases hb : o.isOut f.val <;> simp? · unfold EdgeSubset.oddSignFn congr 1 exact congrArg φ.val (Subtype.ext (κ.match_invol _ f.prop)) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaCotensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaCotensor.lean index ccf6c7b9a5..0a7b95da6f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaCotensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaCotensor.lean @@ -69,13 +69,13 @@ theorem lambda_evenPair {V W : SuperVect} SuperVect.Hom _ _).evenMap (evenPair v w) = (g : SuperVect.Hom _ _).evenMap v * (h : SuperVect.Hom _ _).evenMap w := by - show ((λ_ (𝟙_ SuperVect)).hom : SuperVect.Hom _ _).evenMap + 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] - show (TensorProduct.lid ℂ ℂ).toLinearMap + change (TensorProduct.lid ℂ ℂ).toLinearMap ((LinearMap.fst ℂ _ _) (evenPair ((g : SuperVect.Hom _ _).evenMap v) ((h : SuperVect.Hom _ _).evenMap w))) = _ @@ -101,7 +101,7 @@ theorem omegaFun_tensor {a b : ℕ} (((μ P.ω (SkeinObj.mk a) (SkeinObj.mk b)) : SuperVect.Hom _ _).evenMap (evenPair v w)) = omegaFun f P q₁ v * omegaFun f P q₂ w := by - letI := P.braided + let := P.braided have hhom : (λ_ (𝟙_ (SkeinObj f))).hom = 𝟙 (𝟙_ (SkeinObj f)) := by have h1 := Iso.hom_inv_id (λ_ (𝟙_ (SkeinObj f))) @@ -121,7 +121,7 @@ theorem omegaFun_tensor {a b : ℕ} (z : SuperVect.Hom _ _).evenMap (evenPair v w)) habs refine Eq.trans ?_ (Eq.trans hev ?_) · rfl - · show ((((P.ω.map q₁ ≫ η P.ω) ⊗ₘ (P.ω.map q₂ ≫ η P.ω)) ≫ + · change ((((P.ω.map q₁ ≫ η P.ω) ⊗ₘ (P.ω.map q₂ ≫ η P.ω)) ≫ (λ_ (𝟙_ SuperVect)).hom : P.ω.obj (SkeinObj.mk a) ⊗ P.ω.obj (SkeinObj.mk b) ⟶ SuperVect.tensorUnit) : @@ -137,8 +137,8 @@ theorem omegaFun_comp {a b : ℕ} (v : (P.ω.obj (SkeinObj.mk a)).even) : omegaFun f P (p ≫ q) v = omegaFun f P q ((P.ω.map p).evenMap v) := by - letI := P.braided - show ((P.ω.map (p ≫ q) ≫ η P.ω : P.ω.obj (SkeinObj.mk a) ⟶ + let := P.braided + change ((P.ω.map (p ≫ q) ≫ η P.ω : P.ω.obj (SkeinObj.mk a) ⟶ SuperVect.tensorUnit) : SuperVect.Hom _ _).evenMap v = _ rw [P.ω.map_comp] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaStarVec.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaStarVec.lean index 1587b9c62c..763a39d643 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaStarVec.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaStarVec.lean @@ -46,7 +46,7 @@ theorem omegaVec_starTensorClass : ∀ (ds : List ℕ), rw [starTensorClass_nil, empty_class_eq_id] rfl | d :: ds => by - letI := P.braided + let := P.braided refine (congrArg (omegaVec f P) (starTensorClass_cons f d ds)).trans ?_ refine (omegaVec_comp f P diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean index 65917d74f2..01c177d9ca 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean @@ -49,7 +49,7 @@ variable {R : ℕ} (f : EdgeRankParameter R) the identity. -/ theorem skein_leftUnitor_unit_inv : (λ_ (𝟙_ (SkeinObj f))).inv = 𝟙 (𝟙_ (SkeinObj f)) := by - show bundleMapClass f (finCongr _) = _ + 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)] @@ -64,8 +64,8 @@ theorem omegaVec_comp {a b : ℕ} (q : (SkeinObj.mk a : SkeinObj f) ⟶ SkeinObj.mk b) : omegaVec f P (p ≫ q) = (P.ω.map q).evenMap (omegaVec f P p) := by - letI := P.braided - show ((ε P.ω ≫ P.ω.map (p ≫ q) : SuperVect.tensorUnit ⟶ + let := P.braided + change ((ε P.ω ≫ P.ω.map (p ≫ q) : SuperVect.tensorUnit ⟶ P.ω.obj (SkeinObj.mk b)) : SuperVect.Hom _ _).evenMap 1 = _ rw [P.ω.map_comp] @@ -75,8 +75,8 @@ theorem omegaVec_comp {a b : ℕ} 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 - letI := P.braided - show ((ε P.ω ≫ P.ω.map (r • p) : SuperVect.tensorUnit ⟶ + 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 @@ -93,8 +93,8 @@ theorem tensorHom_evenPair {V₁ V₂ W₁ W₂ : SuperVect} SuperVect.Hom _ _).evenMap (evenPair v w) = evenPair ((g : SuperVect.Hom _ _).evenMap v) ((h : SuperVect.Hom _ _).evenMap w) := by - show (SuperVect.tensorHom g h).evenMap (evenPair v w) = _ - show ((TensorProduct.map (g : SuperVect.Hom _ _).evenMap + 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) = _ @@ -109,7 +109,7 @@ theorem superVect_leftUnitor_inv_one : SuperVect.tensorUnit) : SuperVect.Hom _ _).evenMap (1 : ℂ) = evenPair (1 : ℂ) (1 : ℂ) := by - show (LinearMap.inl ℂ _ _ ∘ₗ + change (LinearMap.inl ℂ _ _ ∘ₗ (TensorProduct.lid ℂ ℂ).symm.toLinearMap) 1 = _ rw [LinearMap.comp_apply] rw [show (TensorProduct.lid ℂ ℂ).symm.toLinearMap (1 : ℂ) = @@ -142,7 +142,7 @@ theorem omegaVec_tensor {a b : ℕ} P.ω.obj (SkeinObj.mk a ⊗ SkeinObj.mk b)) => (z : SuperVect.Hom _ _).evenMap (1 : ℂ)) habs refine Eq.trans hev ?_ - show ((μ P.ω (SkeinObj.mk a) (SkeinObj.mk b)) : + change ((μ P.ω (SkeinObj.mk a) (SkeinObj.mk b)) : SuperVect.Hom _ _).evenMap ((((ε P.ω ≫ P.ω.map p) ⊗ₘ (ε P.ω ≫ P.ω.map q) : SuperVect.tensorObj SuperVect.tensorUnit diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTransport.lean index 0d46b9f434..6fb5c8827f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTransport.lean @@ -39,7 +39,7 @@ theorem omega_star (W : ClosedFragment) : (edgeCount W + edgeCount W)) (starClass f W) ≫ P.ω.map (bundleCapClass f (edgeCount W)) = f.val W • 𝟙 (P.ω.obj (SkeinObj.mk 0)) := by - letI := P.linear + let := P.linear rw [← Functor.map_comp] rw [show (starClass f W ≫ bundleCapClass f (edgeCount W) : (SkeinObj.mk 0 : SkeinObj f) ⟶ SkeinObj.mk 0) = @@ -62,7 +62,7 @@ theorem omega_star_scalar (W : ClosedFragment) : η P.ω : SuperVect.tensorUnit ⟶ SuperVect.tensorUnit) : SuperVect.Hom SuperVect.tensorUnit SuperVect.tensorUnit).evenMap 1 = f.val W := by - letI := P.braided + let := P.braided rw [omega_star f P W] rw [CategoryTheory.Linear.smul_comp, CategoryTheory.Linear.comp_smul] @@ -73,7 +73,7 @@ theorem omega_star_scalar (W : ClosedFragment) : SuperVect.tensorUnit) = 𝟙 _ := Functor.Monoidal.ε_η P.ω rw [h2] - show f.val W * 1 = f.val W + change f.val W * 1 = f.val W ring open Functor.LaxMonoidal Functor.OplaxMonoidal in @@ -101,7 +101,7 @@ theorem skein_std_model : (ε P.ω ≫ P.ω.map (η_ (SkeinObj.mk 1) (SkeinObj.mk 1)) ≫ δ P.ω (SkeinObj.mk 1) (SkeinObj.mk 1)) = stdCopair k ℓ := by - letI := P.braided + let := P.braided exact braided_std_model P.ω (SkeinObj.mk 1) (strand_ev_symmetry f) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OneBasis.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OneBasis.lean index af4c1813ea..d3eab4307d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OneBasis.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OneBasis.lean @@ -104,9 +104,9 @@ theorem evenBasisVec_one (i : Fin k) : Pi.single ⟨oneColourE k ℓ i, oneColourE_isEven i⟩ 1 from (colourPowerEquiv k ℓ 1).evenEquiv.apply_symm_apply _] funext ⟨c', hc'⟩ - show _ = ((colourPowerEquiv k ℓ 1).evenEquiv + change _ = ((colourPowerEquiv k ℓ 1).evenEquiv (evenPair (1 : ℂ) (stdE k i)) ⟨c', hc'⟩) - show _ = (colourPowerStep k ℓ 0).evenEquiv + change _ = (colourPowerStep k ℓ 0).evenEquiv ((TensorProduct.congr (colourPowerZero k ℓ).evenEquiv (LinearEquiv.refl ℂ (Fin k → ℂ))) @@ -115,7 +115,7 @@ theorem evenBasisVec_one (i : Fin k) : (colourPowerZero k ℓ).oddEquiv (LinearEquiv.refl ℂ (Fin (2 * ℓ) → ℂ))) 0) ⟨c', hc'⟩ rw [TensorProduct.congr_tmul, map_zero] - show _ = Sum.elim + change _ = Sum.elim (fun p => funTensorFun _ _ (((colourPowerZero k ℓ).evenEquiv (1 : ℂ)) ⊗ₜ[ℂ] (LinearEquiv.refl ℂ (Fin k → ℂ) (stdE k i))) p) @@ -192,9 +192,9 @@ theorem oddBasisVec_one (a : Fin (2 * ℓ)) : Pi.single ⟨oneColourO k ℓ a, oneColourO_not_isEven a⟩ 1 from (colourPowerEquiv k ℓ 1).oddEquiv.apply_symm_apply _] funext ⟨c', hc'⟩ - show _ = ((colourPowerEquiv k ℓ 1).oddEquiv + change _ = ((colourPowerEquiv k ℓ 1).oddEquiv (oddUnitPad (stdF ℓ a)) ⟨c', hc'⟩) - show _ = (colourPowerStep k ℓ 0).oddEquiv + change _ = (colourPowerStep k ℓ 0).oddEquiv ((TensorProduct.congr (colourPowerZero k ℓ).evenEquiv (LinearEquiv.refl ℂ (Fin (2 * ℓ) → ℂ))) @@ -203,7 +203,7 @@ theorem oddBasisVec_one (a : Fin (2 * ℓ)) : (colourPowerZero k ℓ).oddEquiv (LinearEquiv.refl ℂ (Fin k → ℂ))) 0) ⟨c', hc'⟩ rw [TensorProduct.congr_tmul, map_zero] - show _ = Sum.elim + change _ = Sum.elim (fun p => funTensorFun _ _ (((colourPowerZero k ℓ).evenEquiv (1 : ℂ)) ⊗ₜ[ℂ] (LinearEquiv.refl ℂ (Fin (2 * ℓ) → ℂ) (stdF ℓ a))) p) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OrbitCard.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OrbitCard.lean index 8413e37b78..a9772b4538 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OrbitCard.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OrbitCard.lean @@ -34,7 +34,11 @@ set. -/ abbrev Orbits (π : Perm β) : Type := Quotient (SameCycle.setoid π) /-- The orbit space of a permutation of a finite type is finite. -/ -instance [Fintype β] (π : Perm β) : Finite (Orbits π) := Quotient.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 π) := @@ -82,10 +86,10 @@ 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 [dif_pos hx, dif_pos (eq_of_sameCycle_of_fixed hx h ▸ hx)] + · 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 [dif_neg hx, dif_neg (apply_ne_of_sameCycle hx h)] + · 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. -/ @@ -109,14 +113,14 @@ noncomputable def orbitsEquiv [Fintype β] [DecidableEq β] (π : Perm β) : | Sum.inr x => Quotient.mk (SameCycle.setoid π) x.val left_inv := by refine Quotient.ind (fun x => ?_) - show (match orbitName π x with + 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 [dif_pos hx] - · rw [dif_neg hx] + · rw [dite_eq_left hx] + · rw [dite_eq_right hx] refine Quotient.sound ?_ have hmem := cycleRep_mem (⟨π.cycleOf x, cycleOf_mem_cycleFactorsFinset_iff.mpr @@ -135,14 +139,14 @@ noncomputable def orbitsEquiv [Fintype β] [DecidableEq β] (π : Perm β) : rw [← cycleOf_mem_cycleFactorsFinset_iff, hyc] exact hc exact mem_support.mp this - show orbitName π y = Sum.inl ⟨c, hc⟩ + change orbitName π y = Sum.inl ⟨c, hc⟩ unfold orbitName - rw [dif_neg hyne] + rw [dite_eq_right hyne] exact congrArg Sum.inl (Subtype.ext hyc) · have hx' : π x = x := hx - show orbitName π x = Sum.inr ⟨x, hx⟩ + change orbitName π x = Sum.inr ⟨x, hx⟩ unfold orbitName - rw [dif_pos hx'] + rw [dite_eq_left hx'] /-- **The orbit count is the number of orbits.** -/ theorem orbitCount_eq_card_orbits [Fintype β] [DecidableEq β] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OutSignEdges.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OutSignEdges.lean index 764c8d1fef..15ec1fdbab 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OutSignEdges.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OutSignEdges.lean @@ -17,7 +17,7 @@ and non-participating edges contribute 1 on both sides. namespace RS -open Classical Finset +open Finset variable (W : ClosedFragment) (F : EdgeSubset W) {ℓ : ℕ} {κ : F.TransitionSystem} (o : κ.Orientation) (φ : F.OddColouring ℓ) @@ -32,11 +32,11 @@ private noncomputable def outSignFun (x : W.Flag) : ℤ := 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 := - dif_pos hx + dite_eq_left hx private theorem outSignFun_of_not_mem {x : W.Flag} (hx : x ∉ F.flags) : outSignFun W F o φ x = 1 := - dif_neg hx + dite_eq_right hx /-- The subtype product over F.flags equals the full product of the totalized function. -/ @@ -78,24 +78,24 @@ private theorem edge_factor (i : Fin (edgeCount W)) : 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₁, dif_pos 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 [if_pos hb, if_neg hb₁, mul_one] + 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 [if_neg hb, if_pos hb₁, one_mul] + 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₁, - dif_neg hmem, mul_one] + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairEnum.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairEnum.lean index c5b3bae0d3..840b0ebf87 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairEnum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairEnum.lean @@ -16,7 +16,7 @@ in the fixed order, each followed by its match. namespace RS -open Classical Finset +open Finset variable {α : Type} {W : Fragment α} {F : EdgeSubset W} {ℓ : ℕ} {κ : F.TransitionSystem} @@ -34,8 +34,8 @@ noncomputable def defFiveValue (o : κ.Orientation) theorem isOut_of_mem_inFlagsAt (o : κ.Orientation) {v : W.Vertex} {f : W.Flag} (hf : f ∈ F.inFlagsAt o v) : o.isOut f = false := by - letI := W.flagOrder - letI := Classical.dec + let := W.flagOrder + let := Classical.dec unfold EdgeSubset.inFlagsAt at hf exact (Finset.mem_filter.mp ((Finset.mem_sort _).mp hf)).2.2 @@ -94,13 +94,13 @@ theorem oddListAt_eq_map (o : κ.Orientation) rfl have h1 : defFiveValue o φ f = φ.val f := by rw [defFiveValue, hin] - rw [if_neg Bool.false_ne_true] + 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, if_pos hout] - show F.oddPairFn κ φ f = _ + rw [defFiveValue, ite_eq_left hout] + change F.oddPairFn κ φ f = _ rw [EdgeSubset.oddPairFn, List.map_cons, List.map_cons, List.map_nil, h1, h2] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairList.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairList.lean index bbeeae5e9f..ffc5f90014 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairList.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairList.lean @@ -16,7 +16,7 @@ exactly once. The slot helpers identify the two ends of each edge. namespace RS -open Classical Finset +open Finset /-! ### Edge enumeration -/ @@ -124,7 +124,7 @@ theorem mem_edgePairList (W : ClosedFragment) 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 show edgeCount W + (q.val - edgeCount W) = q.val; omega) + 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 @@ -159,7 +159,7 @@ theorem orientedPairList_nodup (W : ClosedFragment) -- 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 [if_pos ho] + · rw [ite_eq_left ho] refine List.nodup_cons.mpr ⟨?_, List.nodup_singleton _⟩ intro hmem rw [List.mem_singleton] at hmem @@ -167,7 +167,7 @@ theorem orientedPairList_nodup (W : ClosedFragment) (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 [if_neg ho] + · rw [ite_eq_right ho] refine List.nodup_cons.mpr ⟨?_, List.nodup_singleton _⟩ intro hmem rw [List.mem_singleton] at hmem @@ -200,7 +200,7 @@ theorem orientedPairList_nodup (W : ClosedFragment) intro i hmem by_cases ho : o.isOut ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) i.val)) = true - · rw [if_pos ho] at hmem + · rw [ite_eq_left ho] at hmem rcases List.mem_cons.mp hmem with h | h · right rw [show x.val = (starFlagEnum W).symm @@ -211,7 +211,7 @@ theorem orientedPairList_nodup (W : ClosedFragment) rw [show x.val = (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i.val) from congrArg Subtype.val h, _root_.Equiv.apply_symm_apply] - · rw [if_neg ho] at hmem + · rw [ite_eq_right ho] at hmem rcases List.mem_cons.mp hmem with h | h · left rw [show x.val = (starFlagEnum W).symm @@ -246,12 +246,12 @@ theorem mem_orientedPairList (W : ClosedFragment) refine ⟨i, hi, ?_⟩ by_cases ho : o.isOut ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) i.val)) = true - · rw [if_pos ho] + · 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 [if_neg ho] + · 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 index b33498c2b5..c22c9eb94e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ParameterModel.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ParameterModel.lean @@ -42,7 +42,7 @@ theorem stdToOmega_bmc_perm_all : (σ : Fin n ≃ Fin n)) = modelPermMap σ ≫ stdToOmega f P e n | 0, σ => by - letI := P.braided + let := P.braided rw [show (σ : Fin 0 ≃ Fin 0) = _root_.Equiv.refl (Fin 0) from Subsingleton.elim _ _] @@ -51,7 +51,7 @@ theorem stdToOmega_bmc_perm_all : bundleMapClass_refl f 0] rw [show P.ω.map (𝟙 (SkeinObj.mk 0 : SkeinObj f)) = 𝟙 (P.ω.obj (SkeinObj.mk 0)) from P.ω.map_id _] - show stdToOmega f P e 0 ≫ 𝟙 _ = + 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 σ @@ -82,7 +82,7 @@ theorem parameter_model (W : ClosedFragment) SuperVect.Hom _ _).evenMap (modelStarVec f P e' (degList (starAssignEnum W)))))) := by - letI := P.braided + 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) ?_ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PatternInv.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PatternInv.lean index c79535c6e1..3b23a391bb 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PatternInv.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PatternInv.lean @@ -16,7 +16,7 @@ participating slots, a pure `(W, F)` quantity. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PowMerge.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PowMerge.lean index 3a707d66d5..be5fa2ce20 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PowMerge.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PowMerge.lean @@ -49,11 +49,11 @@ theorem stdToOmega_merge : powMerge (stdSuperPair k ℓ) a b ≫ stdToOmega f P e (a + b) -- ═══════ b = 0: THE RIGHT UNITOR ═══════ | a, 0 => by - letI := P.braided + let := P.braided -- The skein right unitor at `a` is the identity. have hρ : (ρ_ (SkeinObj.mk a : SkeinObj f)).hom = 𝟙 (SkeinObj.mk a) := by - show bundleMapClass f (finCongr _) = _ + 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)] @@ -68,7 +68,7 @@ theorem stdToOmega_merge : rw [show P.ω.map (𝟙 (SkeinObj.mk a : SkeinObj f)) = 𝟙 (P.ω.obj (SkeinObj.mk a)) from P.ω.map_id _] at h0 exact h0.symm - show (stdToOmega f P e a ⊗ₘ ε P.ω) ≫ + change (stdToOmega f P e a ⊗ₘ ε P.ω) ≫ μ P.ω (SkeinObj.mk a) (SkeinObj.mk 0) = (ρ_ (superPow (stdSuperPair k ℓ) a)).hom ≫ stdToOmega f P e a @@ -77,9 +77,9 @@ theorem stdToOmega_merge : exact MonoidalCategory.rightUnitor_naturality _ -- ═══════ b + 1: PEEL ONE TENSOR FACTOR ═══════ | a, b + 1 => by - letI := P.braided + let := P.braided -- Expand the right transport one step. - show (stdToOmega f P e a ⊗ₘ + 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)) = @@ -105,7 +105,7 @@ theorem stdToOmega_merge : rw [show (α_ (SkeinObj.mk a : SkeinObj f) (SkeinObj.mk b) (SkeinObj.mk 1)).inv = 𝟙 (SkeinObj.mk (a + (b + 1))) from by - show bundleMapClass f (finCongr _) = _ + change bundleMapClass f (finCongr _) = _ rw [show (finCongr (show a + (b + 1) = a + b + 1 by omega) : Fin (a + (b + 1)) ≃ Fin (a + (b + 1))) = diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean index 504250a8dd..7532cd5998 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean @@ -34,7 +34,7 @@ the index arithmetic of a list of pairs. namespace RS -open Classical Finset Equiv +open Finset Equiv variable {k ℓ : ℕ} @@ -60,7 +60,7 @@ private theorem slot_of_orientedBlock' {W : ClosedFragment} {F : EdgeSubset W} 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 [if_pos ho] at hx + · rw [ite_eq_left ho] at hx rcases List.mem_cons.mp hx with h | h · right rw [show x.val = (starFlagEnum W).symm @@ -71,7 +71,7 @@ private theorem slot_of_orientedBlock' {W : ClosedFragment} {F : EdgeSubset W} rw [show x.val = (starFlagEnum W).symm (Fin.castAdd (edgeCount W) i.val) from congrArg Subtype.val h, _root_.Equiv.apply_symm_apply] - · rw [if_neg ho] at hx + · rw [ite_eq_right ho] at hx rcases List.mem_cons.mp hx with h | h · left rw [show x.val = (starFlagEnum W).symm @@ -111,7 +111,7 @@ private theorem matchedBlock_classify {W : ClosedFragment} {F : EdgeSubset W} 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 [if_pos ho] at hx + · 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 @@ -137,7 +137,7 @@ private theorem matchedBlock_classify {W : ClosedFragment} {F : EdgeSubset W} rfl · exact ⟨_, partnerMem_of_partEdge c.prop, hxv, Or.inr (_root_.Equiv.apply_symm_apply _ _)⟩ - · rw [if_neg ho] at hx + · 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 @@ -198,12 +198,12 @@ theorem matchedPairList_nodup' (W : ClosedFragment) (F : EdgeSubset W) intro ⟨i, hi⟩ _ by_cases ho : o.isOut ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) i)) = true - · rw [if_pos ho] + · 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 [if_neg ho] + · 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 @@ -250,7 +250,7 @@ theorem mem_matchedPairList' (W : ClosedFragment) (F : EdgeSubset W) set y : {f : W.Flag // f ∈ F.flags} := ⟨κ.match_ x.val, κ.match_mem _ x.prop⟩ have hy_in : o.isOut y.val = false := by - show o.isOut (κ.match_ x.val) = false + 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 @@ -273,18 +273,18 @@ theorem mem_matchedPairList' (W : ClosedFragment) (F : EdgeSubset W) (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 [if_neg h_not_out] + · 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 - show x.val = κ.match_ ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) + 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 show edgeCount W + (q.val - edgeCount W) = q.val; omega) + 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] @@ -310,16 +310,18 @@ theorem mem_matchedPairList' (W : ClosedFragment) (F : EdgeSubset W) (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 [if_pos h_out] + · 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 - show x.val = κ.match_ ((starFlagEnum W).symm (Fin.natAdd (edgeCount W) + 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 + 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 @@ -340,13 +342,13 @@ theorem mem_matchedPairList' (W : ClosedFragment) (F : EdgeSubset W) (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 [if_neg h_not_out] + · 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 show edgeCount W + (q.val - edgeCount W) = q.val; omega) + 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] @@ -371,7 +373,7 @@ theorem mem_matchedPairList' (W : ClosedFragment) (F : EdgeSubset W) (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 [if_pos h_out] + · rw [ite_eq_left h_out] exact List.mem_cons.mpr (Or.inl (Subtype.ext hmem.symm)) /-! ## Nodup and membership: global pair list -/ @@ -506,11 +508,11 @@ private theorem matchedInFlag_isIn (W : ClosedFragment) (F : EdgeSubset W) unfold matchedInFlag by_cases ho : o.isOut ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) e.val)) = true - · rw [if_pos ho] + · 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 [if_neg ho] + · rw [ite_eq_right ho] cases hb : o.isOut ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) e.val)) · rfl @@ -649,15 +651,15 @@ private theorem matchedBase_nodup (W : ClosedFragment) (F : EdgeSubset W) (Fin.castAdd (edgeCount W) e₁)) = true <;> by_cases ho₂ : o.isOut ((starFlagEnum W).symm (Fin.castAdd (edgeCount W) e₂)) = true - · rw [if_pos ho₁, if_pos ho₂] at hv + · rw [ite_eq_left ho₁, ite_eq_left ho₂] at hv exact Fin.natAdd_injective _ _ ((starFlagEnum W).symm.injective hv) - · rw [if_pos ho₁, if_neg ho₂] at 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 [if_neg ho₁, if_pos ho₂] at hv + · 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 [if_neg ho₁, if_neg ho₂] at hv + · 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. -/ @@ -671,6 +673,14 @@ private theorem getElem_val_irrel {α : Type*} (l : List α) {a b : Nat} -- Raised budget: 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 @@ -882,13 +892,7 @@ theorem sign_listIndexPerm_oriented_matched (W : ClosedFragment) (F : EdgeSubset -- 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 - intro k hk - apply Subtype.ext - rw [EdgeSubset.TransitionSystem.walkPerm_val] - show κ.match_ (W.pairing (W.pairing (mB[k]'hk).val)) = κ.match_ - (mB[k]'hk).val - congr 1 - exact W.pairing_invol _ + 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 @@ -1082,7 +1086,7 @@ theorem sign_listIndexPerm_matched_global (W : ClosedFragment) (F : EdgeSubset 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 at this; exact this + have := Option.some.inj hM2k_even; simp? 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 _ @@ -1139,7 +1143,7 @@ theorem sign_listIndexPerm_matched_global (W : ClosedFragment) (F : EdgeSubset rw [List.getElem?_eq_getElem h2j1_lt] exact congrArg some hG2j1_eq exact nodup_getElem?_inj hG hGm1_opt hG2j1_opt - show m1 = m + 1 + change m1 = m + 1 rw [hm1_eq, hm_eq] end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexBij.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexBij.lean index 1e6e6511f4..03237d328d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexBij.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexBij.lean @@ -16,7 +16,7 @@ colouring data through the diagonal parametrization. namespace RS open CategoryTheory Finset -open Classical + variable {R : ℕ} (f : EdgeRankParameter R) variable (P : DelignePackage (SkeinObj f)) @@ -96,6 +96,7 @@ theorem fibreSum_eq_dataSum (W : ClosedFragment) 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} => diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexHeart.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexHeart.lean index c5ae6f90c7..7a586e9f99 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexHeart.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexHeart.lean @@ -19,7 +19,7 @@ namespace RS open CategoryTheory MonoidalCategory Finset open Functor.LaxMonoidal Functor.OplaxMonoidal -open Classical + variable {R : ℕ} (f : EdgeRankParameter R) variable (P : DelignePackage (SkeinObj f)) @@ -187,6 +187,7 @@ theorem masterSummand_colouringOfFlip rw [hL0, hR0] ring +open scoped Classical in /-- **The fibre identity**, assembled from the vanishing branches and the termwise value identity. -/ theorem fibreSum_eq @@ -206,9 +207,9 @@ theorem fibreSum_eq else 0 else 0) := by by_cases hc : ∀ g ∈ s, W.pairing g ∈ s - · rw [dif_pos hc] + · rw [dite_eq_left hc] by_cases hE : (EdgeSubset.mk s hc).Eulerian - · rw [if_pos hE] + · rw [ite_eq_left hE] set F := EdgeSubset.mk s hc with hF obtain ⟨⟨κ, o⟩⟩ := ClosedFragment.eulerian_transition_nonempty W F hE @@ -265,12 +266,12 @@ theorem fibreSum_eq F.mixedSummand (hRS f P e') o from rfl] exact (mixedValue_eq_summand_closed W F (hRS f P e') o).symm - · rw [if_neg hE] + · 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 [dif_neg hc] + · 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 @@ -296,6 +297,7 @@ theorem parameter_eq_mixedPartition (W : ClosedFragment) δ 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 = diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexVanish.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexVanish.lean index cc5c4e5d06..ba1c6db041 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexVanish.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexVanish.lean @@ -18,7 +18,7 @@ the odd-degree vertex is a block of odd parity. namespace RS open CategoryTheory Finset -open Classical + variable {R : ℕ} (f : EdgeRankParameter R) variable (P : DelignePackage (SkeinObj f)) @@ -100,7 +100,7 @@ theorem masterSummand_vanish_of_not_closed 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, if_neg h] + rw [colourFormEntry_odd, stdFormOdd_stdF, ite_eq_right h] -- Raised budget: the vanishing is located at one off-diagonal -- slot, but reaching it unfolds the whole summand. @@ -134,14 +134,14 @@ theorem masterSummand_vanish_of_not_diagonal (b := edgeCount W) c) j)) = 0 from ?_] · rw [mul_zero] refine Finset.prod_eq_zero (Finset.mem_univ i) ?_ - show colourFormEntry k ℓ (c (Fin.castAdd (edgeCount W) 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 [if_neg (fun hab => hi (by + rw [ite_eq_right (fun hab => hi (by rw [hy, hx, hab] rfl))] · exfalso diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RepFlag.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RepFlag.lean index 3b9720101e..bff53bc8f9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RepFlag.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RepFlag.lean @@ -18,7 +18,7 @@ the Definition 5 odd lists. namespace RS -open Classical Finset +open Finset /-- The representative flag of a flag's edge: the one on the low slot half. -/ @@ -30,12 +30,12 @@ noncomputable def repFlag (W : ClosedFragment) (g : W.Flag) : /-- 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 := if_pos h + 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 := if_neg h + repFlag W g = W.pairing g := ite_eq_right h /-- The representative flag is pairing-invariant. -/ theorem repFlag_pairing (W : ClosedFragment) (g : W.Flag) : @@ -45,18 +45,18 @@ theorem repFlag_pairing (W : ClosedFragment) (g : W.Flag) : have hhigh : ¬ (starFlagEnum W (W.pairing g)).val < edgeCount W := by rw [hp] - show ¬ edgeCount W + _ < edgeCount W + change ¬ edgeCount W + _ < edgeCount W omega - rw [repFlag, if_neg hhigh, W.pairing_invol, + 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] - show (starFlagEnum W g).val - edgeCount W < edgeCount W + change (starFlagEnum W g).val - edgeCount W < edgeCount W omega - rw [repFlag, if_pos hlow, repFlag_high W g h] + rw [repFlag, ite_eq_left hlow, repFlag_high W g h] open Classical in /-- The flip set of an orientation: participating flags whose diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RiffleSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RiffleSign.lean index 93265b6d9d..6ec543e711 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RiffleSign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RiffleSign.lean @@ -18,7 +18,7 @@ is the number of edges whose representative flag is outgoing. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} @@ -100,12 +100,12 @@ private theorem filter_lt_castAdd_head_eq_zero {n : ℕ} obtain ⟨x, hx, hq⟩ := hq rcases List.mem_cons.mp hq with rfl | hq · -- q = castAdd x, x > e - show (Fin.castAdd n e).val ≤ (Fin.castAdd n x).val + 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 - show (Fin.castAdd n e).val ≤ (Fin.natAdd n x).val + change (Fin.castAdd n e).val ≤ (Fin.natAdd n x).val simp only [Fin.val_castAdd, Fin.val_natAdd] have := e.isLt; omega @@ -139,12 +139,12 @@ private theorem filter_lt_natAdd_head_eq_length {n : ℕ} (List.mem_cons_of_mem _ hy) rw [ih hxs_gt] -- Filter of [castAdd x, natAdd x]: castAdd x passes, natAdd x doesn't - show (([Fin.castAdd n x, Fin.natAdd n x].filter + 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 - show (Fin.castAdd n x).val < (Fin.natAdd n e).val + 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 @@ -174,7 +174,7 @@ private theorem inversions_interleave_sorted {n : ℕ} : -- :: 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) - show ((Fin.natAdd n e :: rest_fm).filter + 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) = _ @@ -213,10 +213,11 @@ private theorem partEdges_length (W : ClosedFragment) (F : EdgeSubset W) : /-! ### Part 1 helpers: crossings count -/ /-- Ordered pairs from a finset biject with choose 2. -/ -private theorem card_ordered_pairs_eq_choose {α : Type*} [DecidableEq α] +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 => @@ -440,14 +441,14 @@ private theorem inversions_oriented_interleave {n : ℕ} -- (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 - show (rest.flatMap (fun i => + 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 [if_pos hsw]; exact List.Perm.swap _ _ _ - · rw [if_neg hsw]) + · 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 @@ -461,40 +462,40 @@ private theorem inversions_oriented_interleave {n : ℕ} -- Now handle the head element's contribution by_cases hsw_e : sw e = true · -- Swapped: [natAdd e, castAdd e] ++ rest_fm - rw [if_pos hsw_e] + rw [ite_eq_left hsw_e] simp only [List.cons_append, List.nil_append] -- inversions (natAdd :: castAdd :: rest_fm) - show ((Fin.castAdd n e :: rest_fm).filter + 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 - show (Fin.castAdd n e).val < (Fin.natAdd n e).val + change (Fin.castAdd n e).val < (Fin.natAdd n e).val simp only [Fin.val_castAdd, Fin.val_natAdd]; omega - rw [List.filter_cons, if_pos (show decide (Fin.castAdd n e < Fin.natAdd n + 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, if_pos hsw_e, List.length_cons] + 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 [if_neg hsw_e] + rw [ite_eq_right hsw_e] simp only [List.cons_append, List.nil_append] -- inversions (castAdd :: natAdd :: rest_fm) - show ((Fin.natAdd n e :: rest_fm).filter + 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, if_neg (show ¬ decide (Fin.natAdd n e < Fin.castAdd + 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, if_neg hsw_e] + rw [List.filter_cons, ite_eq_right hsw_e] simp only [show Nat.succ 1 = 2 from rfl]; omega open Classical in diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SignPair.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SignPair.lean index b7ba66e10f..d935f12da3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SignPair.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SignPair.lean @@ -17,7 +17,7 @@ the transport plus a square. namespace RS -open Classical + /-- **The sign pairing**: mapped sorting signs of two enumerations multiply to the reindexing sign. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SkeinPowBraid.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SkeinPowBraid.lean index 7364059b12..db92c6a5f1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SkeinPowBraid.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SkeinPowBraid.lean @@ -86,7 +86,7 @@ identity. -/ theorem skein_associator_collapse (n : ℕ) : (α_ (SkeinObj.mk n : SkeinObj f) (SkeinObj.mk 1) (SkeinObj.mk 1)).hom = 𝟙 (SkeinObj.mk (n + 2)) := by - show bundleMapClass f (finCongr _) = _ + 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 @@ -98,7 +98,7 @@ 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 - show bundleMapClass f (finCongr _) = _ + 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 @@ -123,15 +123,15 @@ theorem stdToOmega_powBraid : | 0, _, h => absurd h (by omega) | 1, _, h => absurd h (by omega) | n + 2, i, h => by - letI := P.braided + 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 dif_pos hi] + (SkeinObj.mk 1)).hom from dite_eq_left hi] rw [show powBraid (stdSuperPair k ℓ) (n + 2) i h = - topBraid (stdSuperPair k ℓ) n from dif_pos hi] + topBraid (stdSuperPair k ℓ) n from dite_eq_left hi] have hcollapse : ((SkeinObj.mk n : SkeinObj f) ◁ (β_ (SkeinObj.mk 1 : SkeinObj f) @@ -159,11 +159,11 @@ theorem stdToOmega_powBraid : 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 - dif_neg hi] + dite_eq_right hi] rw [show powBraid (stdSuperPair k ℓ) (n + 2) i h = (powBraid (stdSuperPair k ℓ) (n + 1) i hle) ▷ - stdSuperPair k ℓ from dif_neg hi] - show ((stdToOmega f P e (n + 1) ⊗ₘ e) ≫ + 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) = diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortFactor.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortFactor.lean index 5beff62eb5..9c3e555eb1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortFactor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortFactor.lean @@ -32,7 +32,7 @@ assignment. -/ theorem blockAssign_sortEquiv (i : Fin n) : blockAssign (degList assign) (sortEquiv assign i) = finCongr (degList_length assign).symm (assign i) := by - show blockAssign _ + change blockAssign _ (blockSigmaEquiv _ (sortSigma assign i)) = _ rw [blockAssign_blockSigmaEquiv] exact sortSigma_fst assign i diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarClassFactor.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarClassFactor.lean index 11367e03e5..892575a235 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarClassFactor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarClassFactor.lean @@ -54,7 +54,7 @@ theorem sort_transport_eq {N M : ℕ} (σ : Fin N ≃ Fin M) : finSumFinEquiv)) : Fin N ≃ Fin (0 + M)) = σ.trans (finCongr (by omega : M = 0 + M)) := by refine _root_.Equiv.ext (fun x => Fin.ext ?_) - show (finSumFinEquiv ((_root_.Equiv.sumCongr + change (finSumFinEquiv ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin 0)) σ) (finSumFinEquiv.symm (finCongr (by omega : N = 0 + N) x)))).val = _ @@ -62,7 +62,7 @@ theorem sort_transport_eq {N M : ℕ} (σ : Fin N ≃ Fin M) : Fin (0 + N)) = Fin.natAdd 0 x from Fin.ext (show x.val = 0 + x.val by omega), finSumFinEquiv_symm_apply_natAdd] - show 0 + (σ x).val = (σ x).val + change 0 + (σ x).val = (σ x).val omega /-- **The class-level star factorization**: the star-union class diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPeel.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPeel.lean index c9df004a63..76a5cf98ad 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPeel.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPeel.lean @@ -61,7 +61,7 @@ noncomputable def multiStarNil (c : ℕ) : pairing_comm := fun g => g.elim (fun i => i.elim0) (fun i => i.elim0) circles_eq := by - show c = 0 + c + change c = 0 + c omega /-- The head-vertex splitting map. -/ @@ -80,53 +80,53 @@ def peelVertexEquiv (n : ℕ) : Fin (n + 1) ≃ Unit ⊕ Fin n where invFun := peelVertexInv n left_inv v := by by_cases h : v.val = 0 - · have h1 : peelVertexFun n v = Sum.inl () := dif_pos h + · 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⟩ := - dif_neg h + dite_eq_right h rw [h1] exact Fin.ext (by - show v.val - 1 + 1 = v.val + change v.val - 1 + 1 = v.val omega) right_inv x := by rcases x with u | j - · exact dif_pos rfl + · 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⟩ := - dif_neg (show ¬ (j.val + 1 = 0) by 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 - show j.val + 1 - 1 = j.val + 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 - show peelVertexFun n ⟨0, h⟩ = Sum.inl () - exact dif_pos rfl + 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 - show j.val + 1 - 1 < n + change j.val + 1 - 1 < n have := j.isLt omega⟩ := - dif_neg (show ¬ (j.succ.val = 0) from by - show ¬ (j.val + 1 = 0) + dite_eq_right (show ¬ (j.succ.val = 0) from by + change ¬ (j.val + 1 = 0) omega) - show peelVertexFun n j.succ = Sum.inr j + change peelVertexFun n j.succ = Sum.inr j rw [h1] exact congrArg Sum.inr (Fin.ext (by - show j.val + 1 - 1 = j.val + change j.val + 1 - 1 = j.val omega)) /-- The slot shuffle of the peel. -/ @@ -175,6 +175,153 @@ theorem peelFlagEquiv_inr_high (d S : ℕ) (j : Fin S) : 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. -/ @@ -195,133 +342,10 @@ noncomputable def multiStarPeel {n : ℕ} (d S c : ℕ) -- ═══════ ATTACHMENT ═══════ -- Flags below `d` sit on the peeled star, the rest on the -- remaining ones; each side keeps its own vertex. - attach_comm := fun 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] - erw [peelFlagEquiv_inl_low d S ⟨i.val, hi⟩] - show (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] - show 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 - show i.val = d + (i.val - d) - omega)] - erw [peelFlagEquiv_inl_high d S] - show (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] - show 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⟩] - show 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 - show i.val = 0 + i.val - omega), - interleaveEquiv_inl_high] - show (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 - show i.val = d + (i.val - d) - omega)] - erw [peelFlagEquiv_inr_high d S] - show 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 - show i.val - d = 0 + (i.val - d) - omega), - interleaveEquiv_inr_high] - show (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. - pairing_comm := fun 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 - show 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 - show 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 + attach_comm := multiStarPeel_attach_comm d S c rest a ha_low ha_high + pairing_comm := multiStarPeel_pairing_comm d S c rest a circles_eq := by - show c = 0 + c + change c = 0 + c omega /-- Circles migrate out of the second tensor factor. -/ @@ -334,18 +358,18 @@ noncomputable def tensorAddCirclesRight {s t u v : ℕ} vertexEquiv := _root_.Equiv.refl _ attach_comm := fun g => by rcases g with g | g - · show ((A.attach g).map Sum.inl Sum.inl).map id _ = + · 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 - · show ((B.attach g).map Sum.inr Sum.inr).map id _ = + · 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 - show A.circles + (B.circles + c) = + change A.circles + (B.circles + c) = (A.circles + B.circles) + c omega @@ -359,22 +383,22 @@ noncomputable def multiStarBlocks : | d :: ds, c => by refine (multiStarPeel d ds.sum c (blockAssign ds) (blockAssign (d :: ds)) - (fun i => dif_pos i.isLt) + (fun i => dite_eq_left i.isLt) (fun j => by have h1 : ¬ ((Fin.natAdd d j : Fin (d + ds.sum)).val < d) := by - show ¬ (d + j.val < d) + change ¬ (d + j.val < d) omega - refine (dif_neg h1).trans ?_ + refine (dite_eq_right h1).trans ?_ refine congrArg Fin.succ (congrArg (blockAssign ds) (Fin.ext ?_)) - show d + j.val - d = j.val + change d + j.val - d = j.val omega)).trans ?_ refine (Fragment.Equiv.relabelCongr (tensorFragmentCongr (Fragment.Equiv.refl _) (Fragment.Equiv.relabelCongr (multiStarBlocks ds c) _)) _).trans ?_ - show ((tensorFragment + change ((tensorFragment ((vertexStar d).relabel (finCongr (by omega : d = 0 + d))) (addCircles ((starTensor ds).relabel (finCongr diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPerm.lean index 52c5654410..ad59723921 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPerm.lean @@ -44,7 +44,7 @@ theorem stdFromOmega_perm P.ω.obj (SkeinObj.mk d) ⟶ superPow (stdSuperPair k ℓ) d) = P.ω.map (bundleMapClass f (σ : Fin d ≃ Fin d)) ≫ stdFromOmega f P e' d := by - letI := P.braided + let := P.braided have h1 : modelPermMap (k := k) (ℓ := ℓ) σ = stdToOmega f P e d ≫ P.ω.map (bundleMapClass f (σ : Fin d ≃ Fin d)) ≫ @@ -85,7 +85,7 @@ theorem starCoord_perm (c : MixedColouring k ℓ d) : starCoord f P e' d (c ∘ σ) = (-1 : ℂ) ^ oddInversions σ c * starCoord f P e' d c := by - letI := P.braided + let := P.braided have hfix : ((modelPermMap σ) : SuperVect.Hom _ _).evenMap (((stdFromOmega f P e' d) : SuperVect.Hom _ _).evenMap (starVec f P d)) = @@ -97,7 +97,7 @@ theorem starCoord_perm (z : SuperVect.Hom _ _).evenMap (starVec f P d)) (stdFromOmega_perm f P e e' hee' he'e d σ) refine Eq.trans h ?_ - show ((stdFromOmega f P e' d) : + change ((stdFromOmega f P e' d) : SuperVect.Hom _ _).evenMap (((P.ω.map (bundleMapClass f (σ : Fin d ≃ Fin d))) : diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarRepeat.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarRepeat.lean index 80e50a0bfd..1521d98a2e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarRepeat.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarRepeat.lean @@ -37,7 +37,7 @@ theorem oddInversions_adjacent {n : ℕ} (i : ℕ) -- otherwise the pair contributes nothing and the count is fixed. by_cases hodd : (c ⟨i, by omega⟩).isRight ∧ (c ⟨i + 1, h2⟩).isRight - · rw [if_pos hodd] + · 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 > @@ -117,16 +117,16 @@ theorem oddInversions_adjacent {n : ℕ} (i : ℕ) · intro hp rw [hp] refine ⟨Fin.lt_def.mpr (by - show i < i + 1; omega), ?_, ?_, ?_⟩ + change i < i + 1; omega), ?_, ?_, ?_⟩ · rw [_root_.Equiv.swap_apply_left, _root_.Equiv.swap_apply_right] exact Fin.lt_def.mpr (by - show i < i + 1; omega) + change i < i + 1; omega) · rw [_root_.Equiv.swap_apply_left] exact hodd.2 · rw [_root_.Equiv.swap_apply_right] exact hodd.1 - · rw [if_neg hodd] + · rw [ite_eq_right hodd] rw [Finset.card_eq_zero, Finset.filter_eq_empty_iff] rintro p _ ⟨hlt, hgt, ho1, ho2⟩ refine hodd ?_ @@ -203,7 +203,7 @@ theorem starCoord_adjacent_repeat have hfix : c ∘ _root_.Equiv.swap (⟨i, by omega⟩ : Fin d) ⟨i + 1, h2⟩ = c := by funext x - show c (_root_.Equiv.swap _ _ x) = c 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 @@ -216,7 +216,7 @@ theorem starCoord_adjacent_repeat ⟨i + 1, h2⟩) c rw [hfix] at hperm rw [oddInversions_adjacent i h2 c] at hperm - rw [if_pos ⟨hodd, heq ▸ hodd⟩] 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 @@ -241,7 +241,7 @@ theorem starCoord_repeat_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 show i.val + 1 = j.val; omega) + 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 @@ -267,23 +267,23 @@ theorem starCoord_repeat_zero have hb3 : j.val - 1 < d := by have := j.isLt; omega have hbj : (⟨j.val - 1 + 1, hj1⟩ : Fin d) = j := - Fin.ext (by show j.val - 1 + 1 = j.val; omega) + Fin.ext (by change j.val - 1 + 1 = j.val; omega) refine ih (c ∘ σ) i ⟨j.val - 1, hb3⟩ hb1 ?_ ?_ hb2 - · show (c (σ i)).isRight + · change (c (σ i)).isRight rw [show σ i = i from _root_.Equiv.swap_apply_of_ne_of_ne (Fin.ne_of_val_ne (by - show i.val ≠ j.val - 1; omega)) + change i.val ≠ j.val - 1; omega)) (Fin.ne_of_val_ne (by - show i.val ≠ j.val - 1 + 1; omega))] + change i.val ≠ j.val - 1 + 1; omega))] exact hodd - · show c (σ i) = c (σ ⟨j.val - 1, by omega⟩) + · 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 - show i.val ≠ j.val - 1; omega)) + change i.val ≠ j.val - 1; omega)) (Fin.ne_of_val_ne (by - show i.val ≠ j.val - 1 + 1; omega))] + change i.val ≠ j.val - 1 + 1; omega))] rw [show σ ⟨j.val - 1, by have := j.isLt; omega⟩ = ⟨j.val - 1 + 1, hj1⟩ from diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StdTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StdTransport.lean index f31c4b8798..e7ceab4363 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StdTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StdTransport.lean @@ -69,13 +69,13 @@ theorem stdFromOmega_stdToOmega P.ω.obj (SkeinObj.mk m) ⟶ P.ω.obj (SkeinObj.mk m)) = 𝟙 (P.ω.obj (SkeinObj.mk m)) | 0 => by - letI := P.braided - show (η P.ω ≫ ε P.ω : P.ω.obj (SkeinObj.mk 0) ⟶ + let := P.braided + change (η P.ω ≫ ε P.ω : P.ω.obj (SkeinObj.mk 0) ⟶ P.ω.obj (SkeinObj.mk 0)) = 𝟙 _ exact Functor.Monoidal.η_ε P.ω | m + 1 => by - letI := P.braided - show (δ P.ω (SkeinObj.mk m) (SkeinObj.mk 1) ≫ + 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) : @@ -99,13 +99,13 @@ theorem stdToOmega_stdFromOmega superPow (stdSuperPair k ℓ) m) = 𝟙 (superPow (stdSuperPair k ℓ) m) | 0 => by - letI := P.braided - show (ε P.ω ≫ η P.ω : SuperVect.tensorUnit ⟶ + let := P.braided + change (ε P.ω ≫ η P.ω : SuperVect.tensorUnit ⟶ SuperVect.tensorUnit) = 𝟙 _ exact Functor.Monoidal.ε_η P.ω | m + 1 => by - letI := P.braided - show ((stdToOmega f P e m ⊗ₘ e) ≫ + 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)))) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StrandTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StrandTransport.lean index a78f458792..350ab0559c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StrandTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StrandTransport.lean @@ -32,14 +32,14 @@ theorem stdToOmega_one : stdToOmega f P e 1 = (SuperVect.tensorUnit ◁ e) ≫ (λ_ (P.ω.obj (SkeinObj.mk 1))).hom := by - letI := P.braided - show (stdToOmega f P e 0 ⊗ₘ e) ≫ + 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 - show bundleMapClass f (finCongr _) = _ + 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)] @@ -58,9 +58,9 @@ theorem stdToOmega_one_even (x : (stdSuperPair k ℓ).even) : ((stdToOmega f P e 1) : SuperVect.Hom _ _).evenMap (evenPair (1 : ℂ) x) = (e : SuperVect.Hom _ _).evenMap x := by - letI := P.braided + let := P.braided rw [stdToOmega_one] - show (((λ_ (P.ω.obj (SkeinObj.mk 1))).hom : + change (((λ_ (P.ω.obj (SkeinObj.mk 1))).hom : SuperVect.tensorObj SuperVect.tensorUnit (P.ω.obj (SkeinObj.mk 1)) ⟶ P.ω.obj (SkeinObj.mk 1)) : SuperVect.Hom _ _).evenMap @@ -70,7 +70,7 @@ theorem stdToOmega_one_even (x : (stdSuperPair k ℓ).even) : (SuperVect.Hom.id (𝟙_ SuperVect)) e).evenMap (evenPair (1 : ℂ) x) = evenPair (1 : ℂ) ((e : SuperVect.Hom _ _).evenMap x) from by - show ((TensorProduct.map LinearMap.id + change ((TensorProduct.map LinearMap.id (e : SuperVect.Hom _ _).evenMap) ((1 : ℂ) ⊗ₜ[ℂ] x), (TensorProduct.map (SuperVect.Hom.id (𝟙_ SuperVect)).oddMap @@ -92,9 +92,9 @@ theorem stdToOmega_one_odd (y : (stdSuperPair k ℓ).odd) : ((stdToOmega f P e 1) : SuperVect.Hom _ _).oddMap (oddUnitPad y) = (e : SuperVect.Hom _ _).oddMap y := by - letI := P.braided + let := P.braided rw [stdToOmega_one] - show (((λ_ (P.ω.obj (SkeinObj.mk 1))).hom : + change (((λ_ (P.ω.obj (SkeinObj.mk 1))).hom : SuperVect.tensorObj SuperVect.tensorUnit (P.ω.obj (SkeinObj.mk 1)) ⟶ P.ω.obj (SkeinObj.mk 1)) : SuperVect.Hom _ _).oddMap @@ -104,7 +104,7 @@ theorem stdToOmega_one_odd (y : (stdSuperPair k ℓ).odd) : (SuperVect.Hom.id (𝟙_ SuperVect)) e).oddMap (oddUnitPad y) = oddUnitPad ((e : SuperVect.Hom _ _).oddMap y) from by - show ((TensorProduct.map LinearMap.id + change ((TensorProduct.map LinearMap.id (e : SuperVect.Hom _ _).oddMap) ((1 : ℂ) ⊗ₜ[ℂ] y), (TensorProduct.map (SuperVect.Hom.id (𝟙_ SuperVect)).oddMap diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauCount.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauCount.lean index 5f3a5d12d3..93eabb43dc 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauCount.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauCount.lean @@ -16,7 +16,7 @@ to the number of outgoing flags, via the incoming/outgoing partition. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} (W : ClosedFragment) (F : EdgeSubset W) {κ : F.TransitionSystem} (o : κ.Orientation) (φ : F.OddColouring ℓ) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauKey.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauKey.lean index 5be7ed8f9f..221adee493 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauKey.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauKey.lean @@ -18,7 +18,7 @@ pair enumeration alone. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TopBraidMerge.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TopBraidMerge.lean index 79aa73a238..1cb777838f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TopBraidMerge.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TopBraidMerge.lean @@ -91,7 +91,7 @@ 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 - show (superPow V a ◁ topB (superPow V 0) V) ≫ + 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) = @@ -107,7 +107,7 @@ theorem powMerge_isIso (V : SuperVect) (a : ℕ) : ∀ b : ℕ, IsIso (powMerge V a b) | 0 => inferInstanceAs (IsIso (ρ_ (superPow V a)).hom) | b + 1 => by - haveI := powMerge_isIso V a b + have := powMerge_isIso V a b exact inferInstanceAs (IsIso ((α_ (superPow V a) (superPow V b) V).inv ≫ ((powMerge V a b) ▷ V))) @@ -117,7 +117,7 @@ theorem powMerge_evenMap_surjective (V : SuperVect) (a b : ℕ) : Function.Surjective (((powMerge V a b) : SuperVect.Hom _ _).evenMap) := by - haveI := powMerge_isIso V a b + have := powMerge_isIso V a b intro v refine ⟨((CategoryTheory.inv (powMerge V a b)) : SuperVect.Hom _ _).evenMap v, ?_⟩ @@ -132,7 +132,7 @@ theorem powMerge_oddMap_surjective (V : SuperVect) (a b : ℕ) : Function.Surjective (((powMerge V a b) : SuperVect.Hom _ _).oddMap) := by - haveI := powMerge_isIso V a b + have := powMerge_isIso V a b intro v refine ⟨((CategoryTheory.inv (powMerge V a b)) : SuperVect.Hom _ _).oddMap v, ?_⟩ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexSign.lean index 5a40de62af..e2d56f7cd8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexSign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexSign.lean @@ -18,7 +18,7 @@ between them, and the block enumeration is key-sorted. namespace RS -open Classical Finset +open Finset variable {k ℓ : ℕ} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexValue.lean index 3e04c0ca30..2cf8ddfeac 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexValue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexValue.lean @@ -19,7 +19,7 @@ the canonical colouring, whose star coordinate the functional namespace RS open CategoryTheory Finset -open Classical + variable {R : ℕ} (f : EdgeRankParameter R) variable (P : DelignePackage (SkeinObj f)) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomicIdempotents.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomicIdempotents.lean index 5aeccefd4e..f0fbb189c6 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomicIdempotents.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomicIdempotents.lean @@ -53,12 +53,12 @@ private theorem matUnit_mul_matUnit {n : ℕ} {d : Fin n → ℕ} dsimp at hij subst hij rcases eq_or_ne pr qr with rfl | hr - · rw [if_pos rfl] + · 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 [if_neg (by + · rw [ite_eq_right (by intro h exact hr (by have := Sigma.mk.inj_iff.mp h @@ -67,7 +67,7 @@ private theorem matUnit_mul_matUnit {n : ℕ} {d : Fin n → ℕ} rcases eq_or_ne k pi with rfl | hk · simp [hr] · simp [Pi.single_eq_of_ne hk] - · rw [if_neg (fun h => hij (congrArg Sigma.fst h))] + · 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, @@ -108,13 +108,13 @@ private theorem matUnit_sum {n : ℕ} {d : Fin n → ℕ} : rw [Finset.sum_eq_single r (fun b _ hb => by simp only [Matrix.single, Matrix.of_apply] - rw [if_neg (by simp [hb])]) + 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 [if_neg (by + rw [ite_eq_right (by rintro ⟨hbr, hbs⟩ exact hrs (hbr ▸ hbs))] @@ -139,7 +139,6 @@ private theorem matUnit_corner {n : ℕ} {d : Fin n → ℕ} · simp [Pi.single_eq_of_ne hk] private theorem matUnit_ne_zero {n : ℕ} {d : Fin n → ℕ} - [∀ i, NeZero (d i)] (p : (i : Fin n) × Fin (d i)) : matUnit p ≠ 0 := by intro h have h2 := congrFun h p.1 @@ -165,15 +164,15 @@ theorem exists_completeOrthogonal_atomic [Ring A] [Algebra ℂ A] fun p => Φ.symm (matUnit p), ⟨⟨fun p => ?_, ?_⟩, ?_⟩, ?_⟩ · show IsIdempotentElem _ rw [IsIdempotentElem, ← map_mul, matUnit_mul_matUnit, - if_pos rfl] + ite_eq_left rfl] · intro p q hpq - rw [← map_mul, matUnit_mul_matUnit, if_neg hpq, map_zero] + 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, - if_pos rfl] + ite_eq_left rfl] · intro h exact matUnit_ne_zero p (by have := congrArg Φ h diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean index c084e34848..2f03d2f90f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean @@ -38,9 +38,9 @@ private theorem finRotate_val' (c : ℕ) (q : Fin (c + 1)) : rw [Fin.val_add_one] at h rw [h] by_cases hq : q.val = c - · rw [if_pos (Fin.ext hq : q = Fin.last c), if_pos hq] - · rw [if_neg (show q ≠ Fin.last c from fun h => - hq (congrArg Fin.val h)), if_neg hq] + · 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). -/ @@ -80,13 +80,13 @@ theorem blockPerm_finRotate_eq_blockRot (n c : ℕ) : rw [lhs_val, rhs_val, finRotate_val' c ⟨q, hq_lt⟩] by_cases hqc : q = c · -- q = c: finRotate wraps, blockRot wraps - rw [if_pos hqc, hqc, if_neg (by omega), + 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 [if_neg hqc, - if_pos (show n * q + r < n * c from + 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 @@ -218,7 +218,7 @@ theorem skeinTrace_block_rot_step (K n : ℕ) (A : skeinEnd f (K + n)) obtain ⟨xa, rfl⟩ := Submodule.Quotient.mk_surjective _ A obtain ⟨xg, rfl⟩ := Submodule.Quotient.mk_surjective _ g -- Convert to Finsupp level - show traceFunctional f.val (K + n + n) + 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)) = @@ -367,7 +367,7 @@ theorem skeinTrace_block_cycle (n k : ℕ) 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 - show skeinTrace f (0 + n) (blockTensorEnd f (1 : skeinEnd f 0) (G 0)) = + 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] @@ -387,7 +387,7 @@ theorem skeinTrace_block_cycle (n k : ℕ) -- Bridge: blockPerm n (finRotate (m+2)) = blockRot (n*(m+1)) n rw [blockPerm_finRotate_eq_blockRot] -- Make additive structure visible for the rot step - show skeinTrace f (n * m + n + n) + 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)) @@ -400,7 +400,7 @@ theorem skeinTrace_block_cycle (n k : ℕ) -- 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) - show skeinTrace f (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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactor.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactor.lean index 3a8d633be8..631d2e0c78 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactor.lean @@ -80,7 +80,7 @@ private theorem endCast_permClass {a b : ℕ} (h : a = b) endCast f h (permClass f a σ) = permClass f b ((finCongr h).permCongr σ) := by subst h - show permClass f a σ = permClass f a _ + change permClass f a σ = permClass f a _ congr 1 /-- `permClass_sumCongr` stated for `blockTensorEnd`. -/ @@ -184,7 +184,7 @@ private theorem blockTensor_assoc {a b c : ℕ} 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 - show (h ▸ blockTensorEnd f (blockTensorEnd f p₁ p₂) p₃ : + 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] @@ -225,12 +225,12 @@ private theorem blockPow_split (n : ℕ) (g : skeinEnd f n) (a : ℕ) : intro b induction b with | zero => - show blockPow f n g a = + 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 - show endCast f (Nat.mul_add n a (k + 1)) + 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) @@ -289,7 +289,7 @@ private theorem blockPerm_sumCongr (n : ℕ) {a b : ℕ} -- Compute π(v/n) = σ(v/n) have hπq : (π ⟨v / n, hqab⟩).val = (σ ⟨v / n, hqa⟩).val := by rw [hπ_def] - show (finSumFinEquiv (Equiv.sumCongr σ τ + 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, @@ -301,7 +301,7 @@ private theorem blockPerm_sumCongr (n : ℕ) {a b : ℕ} (Equiv.sumCongr (blockPerm n σ) (blockPerm n τ)) ⟨v, hv⟩).val = n * (σ ⟨v / n, hqa⟩).val + v % n := by - show (finSumFinEquiv (Equiv.sumCongr (blockPerm n σ) + 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, @@ -325,7 +325,7 @@ private theorem blockPerm_sumCongr (n : ℕ) {a b : ℕ} have hπq : (π ⟨v / n, hqab⟩).val = a + (τ ⟨v / n - a, hqb⟩).val := by rw [hπ_def] - show (finSumFinEquiv (Equiv.sumCongr σ τ + 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 @@ -362,7 +362,7 @@ private theorem blockPerm_sumCongr (n : ℕ) {a b : ℕ} (Equiv.sumCongr (blockPerm n σ) (blockPerm n τ)) ⟨v, hv⟩).val = n * a + (n * (τ ⟨v / n - a, hqb⟩).val + v % n) := by - show (finSumFinEquiv (Equiv.sumCongr (blockPerm n σ) + 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 @@ -424,7 +424,7 @@ private theorem blockSwap01_comm (n : ℕ) (g : skeinEnd f n) : blockTensorEnd f g g = blockTensorEnd f g g * permClass f (n + n) (transposeEquiv n n) := by - show HomSpace.comp f (n + n) (n + n) (n + n) + 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)) = @@ -521,7 +521,7 @@ private theorem blockPerm_swap01_eq_transposeEquiv (n : ℕ) : apply Fin.ext -- finCongr doesn't change .val, so reduce to blockPerm have hv2 : v < n * 2 := by omega - show (blockPerm n (Equiv.swap (0 : Fin 2) 1) + 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 @@ -866,7 +866,7 @@ theorem skeinTrace_blockCycles_mul_pow (n : ℕ) 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 - show skeinTrace f (n * (c + S)) + change skeinTrace f (n * (c + S)) (permClass f (n * (c + S)) (blockPerm n (blockCycles (c :: rest))) * blockPow f n g (c + S)) = diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockSplice.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockSplice.lean index 57004f32ea..80316566d9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockSplice.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockSplice.lean @@ -46,12 +46,12 @@ theorem blockRot_val (a b : ℕ) (x : Fin (a + b)) : · 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 [if_pos h] + simp only [ite_eq_left h] · conv_lhs => rw [show x = (⟨a + (x.val - a), by omega⟩ : Fin (a + b)) from - Fin.ext (by show x.val = a + (x.val - a); omega)] + 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 [if_neg h] + simp only [ite_eq_right h] /-- Inverse value of `blockRot`. -/ private theorem blockRot_symm_val (a b : ℕ) (x : Fin (a + b)) : @@ -61,8 +61,8 @@ private theorem blockRot_symm_val (a b : ℕ) (x : Fin (a + b)) : have hfwd := blockRot_val a b y rw [Equiv.apply_symm_apply] at hfwd by_cases hya : y.val < a - · rw [if_pos hya] at hfwd; rw [if_neg (by omega)]; omega - · rw [if_neg hya] at hfwd; rw [if_pos (by omega)]; omega + · 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 -/ @@ -80,20 +80,20 @@ private def blockOuterPerm (K n : ℕ) : left_inv w := by dsimp only by_cases h : w.val < n - · simp only [dif_pos h, Fin.val_mk] - rw [dif_neg (show ¬ K + K + n + w.val < K + K + n by omega)] + · 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 [dif_neg h, Fin.val_mk] - rw [dif_pos (show w.val - n < K + K + n by have := w.isLt; 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 [dif_pos h, Fin.val_mk] - rw [dif_neg (show ¬ w.val + n < n by omega)] + · 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 [dif_neg h, Fin.val_mk] - rw [dif_pos (show w.val - (K + K + n) < n by have := w.isLt; 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`. -/ @@ -119,7 +119,7 @@ private theorem block_label_val (K n : ℕ) by_cases hlow : ℓ.val < K + n + n · -- Low half: permHighEquiv fixes have hfix : permHighEquiv (blockRot (K + n) n).symm ℓ = ℓ := by - unfold permHighEquiv; exact dif_pos hlow + unfold permHighEquiv; exact dite_eq_left hlow rw [hfix] by_cases h1 : ℓ.val < K + n · -- x-low block @@ -128,12 +128,12 @@ private theorem block_label_val (K n : ℕ) Fin.ext rfl rw [hform, pcReshuffle_xlow] simp only [Fin.val_natAdd, Fin.val_castAdd] - split_ifs <;> omega + 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 [Fin.val_natAdd]; omega) + Fin.ext (by simp []; omega) rw [hform, pcReshuffle_zlow] simp only [Fin.val_natAdd, Fin.val_castAdd] split_ifs <;> omega @@ -151,11 +151,11 @@ private theorem block_label_val (K n : ℕ) by have := ((blockRot (K + n) n).symm (⟨ℓ.val - (K + n + n), hk⟩ : Fin (K + n + n))).isLt omega⟩ := by - unfold permHighEquiv; exact dif_neg (by omega) + 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 [if_pos hk0] at hrot + 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 @@ -169,7 +169,7 @@ private theorem block_label_val (K n : ℕ) simp only [Fin.val_natAdd, Fin.val_castAdd] split_ifs <;> omega · -- x-high block (k >= n case) - rw [if_neg hk0] at hrot + 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 @@ -180,7 +180,7 @@ private theorem block_label_val (K 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, Fin.val_castAdd] + simp only [Fin.val_natAdd] split_ifs <;> omega /-! ### The splice flag identification -/ @@ -208,57 +208,43 @@ private def blockSpliceFlagEquiv (K n : ℕ) : left_inv := by rintro ⟨i, b⟩; dsimp only by_cases hlo : i.val < n - · rw [dif_pos hlo, Sum.elim_inl] - rw [dif_neg (show ¬ (⟨n + i.val, by omega⟩ : Fin (n + n)).val < n by + · 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 [dif_neg hlo, dif_pos hhi, Sum.elim_inl] - rw [dif_pos (show (⟨i.val - (K + n), by have := i.isLt; omega⟩ : + · 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 [dif_neg hlo, dif_neg (show ¬ i.val ≥ K + n by omega), Sum.elim_inr] + · 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 [dif_pos hj, dif_neg (show ¬ (⟨K + n + j.val, + · 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), - dif_pos (show (⟨K + n + j.val, + 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 [dif_neg hj, dif_pos (show (⟨j.val - n, + · 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 [dif_neg (show ¬ (⟨k.val + n, by have := k.isLt; omega⟩ : + rw [dite_eq_right (show ¬ (⟨k.val + n, by have := k.isLt; omega⟩ : Fin (K + n + n)).val < n by simp only []; omega), - dif_neg (show ¬ (⟨k.val + n, by have := k.isLt; 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 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 [dif_pos hlo, dif_pos hlo]; rfl - · by_cases hhi : w.val ≥ K + n - · rw [dif_neg hlo, dif_pos hhi, dif_neg hlo, dif_pos hhi]; rfl - · rw [dif_neg hlo, dif_neg (by omega), dif_neg hlo, dif_neg (by omega)]; rfl - /-! ### The collapsed outer relabel and the rotated transpose -/ /-- Value of the collapsed outer relabel of the splice. -/ @@ -282,7 +268,7 @@ private theorem block_bigE_val (K n : ℕ) rw [hform, outPermEquiv_high] simp only [finCongr_apply, Fin.val_cast, Fin.val_natAdd] rw [blockOuterPerm_val] - simp only [Fin.val_mk] + simp only [] split_ifs <;> omega /-- Value of the rotated-transpose relabel on the right side. -/ @@ -306,10 +292,10 @@ private theorem block_ER_val (K n : ℕ) Fin.ext rfl] rw [inPermEquiv_high] simp only [Fin.val_natAdd] - rw [if_pos hlow] + 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 show x.val = (K + n) + (x.val - (K + n)); omega)] + (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⟩ : @@ -352,14 +338,12 @@ private noncomputable def compose_relabel_castOut /-! ### The bridge: the rotation as through-strands and cups -/ -/-- **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. -/ -private noncomputable def block_bridge (K n : ℕ) : - ((strandBundle (K + n + n)).relabel +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))).Equiv - (((tensorFragment (s := n + n) (t := n + n) (u := 0) (v := K + K) + (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 @@ -367,226 +351,300 @@ private noncomputable def block_bridge (K n : ℕ) : (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 := fun f => by - obtain ⟨w, b⟩ := f - show (((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. - · -- Through-strand low block (wire w < 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 (⟨n + w.val, by omega⟩, !b) from by + Sum.inl (⟨w.val - (K + n), by have := w.isLt; omega⟩, b) from by simp only [blockSpliceFlagEquiv, Equiv.coe_fn_mk] - exact dif_pos hlo] + rw [dite_eq_right hlo, dite_eq_left hhi]] cases b - · -- in-end (b = false): wire w in-label -> through-strand n+w, out end + · -- 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, - Bool.not_false] + Sum.elim_inr, Sum.map_inr, Sum.map_inl] refine congrArg Sum.inr (Fin.ext ?_) - simp only [Bool.not_false, Bool.not_true, reduceIte, - Bool.false_eq_true, if_false, if_true, id_eq] - rw [show (⟨(n + n) + (n + w.val), by omega⟩ : + 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.natAdd (n + n) (⟨n + w.val, by omega⟩ : Fin (n + n)) from + 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) (⟨n + w.val, by omega⟩ : Fin (n + n))))) = + (Fin.castAdd (K + K) + (⟨w.val - (K + n), + by have := w.isLt; omega⟩ : Fin (n + n))))) = Fin.natAdd (n + n) - (⟨n + w.val, by omega⟩ : Fin ((K + n) + (K + n))) from + (⟨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, Fin.val_castAdd] + simp only [Fin.val_natAdd] rw [blockOuterPerm_val] - simp only [Fin.val_mk] + simp only [] split_ifs <;> omega - · -- out-end (b = true): wire w out-label -> through-strand n+w, in end + -- ═══════ 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, - Bool.not_true] + Sum.elim_inr, Sum.map_inr, Sum.map_inl] refine congrArg Sum.inr (Fin.ext ?_) - simp only [Bool.not_false, Bool.not_true, reduceIte, - Bool.false_eq_true, if_false, if_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] + 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.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.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_low] + rw [outPermEquiv_high] rw [block_label_val] - simp only [Fin.val_castAdd] + simp only [Fin.val_natAdd] + rw [blockOuterPerm_val] + simp only [] split_ifs <;> omega - · 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 [dif_neg hlo, dif_pos 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.not_false, Bool.not_true, reduceIte, - Bool.false_eq_true, if_false, if_true, 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 [Bool.not_false, Bool.not_true, reduceIte, - Bool.false_eq_true, if_false, if_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, Fin.val_castAdd] - rw [blockOuterPerm_val] - simp only [Fin.val_mk] - 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 [dif_neg hlo, dif_neg (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.not_false, Bool.not_true, reduceIte, - Bool.false_eq_true, if_false, if_true, 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, Fin.val_castAdd] - rw [blockOuterPerm_val] - simp only [Fin.val_mk] - 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 [Bool.not_false, Bool.not_true, reduceIte, - Bool.false_eq_true, if_false, if_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, Fin.val_castAdd] - rw [blockOuterPerm_val] - simp only [Fin.val_mk] - 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. -/ +private noncomputable def block_bridge (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 := block_bridge_attach_comm K n pairing_comm := fun f => blockSpliceFlagEquiv_pairing K n f.1 f.2 circles_eq := rfl @@ -637,6 +695,220 @@ private def blockFinalFlagEquiv (K n : ℕ) · 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. -/ private noncomputable def block_splice_bridge (K n : ℕ) @@ -661,179 +933,12 @@ private noncomputable def block_splice_bridge (K n : ℕ) show (𝔊.Vertex ⊕ (Empty : Type)) ≃ ((Empty : Type) ⊕ 𝔊.Vertex) from _root_.Equiv.sumComm _ _ - attach_comm := by - rintro (g | ⟨k, c⟩) - -- ═══════ THE FRAGMENT'S OWN FLAGS ═══════ - · -- a G-flag crosses sides - show 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 [Fin.val_natAdd])] - 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_natAdd, 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 [Fin.val_natAdd]; 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_natAdd, 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 - -- ═══════ THE CUP FLAGS ═══════ - · -- a cup flag flips into a through-strand - show 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_inl, Sum.map_inr, - Bool.false_eq_true, if_false, if_true, reduceIte] - 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 [Fin.val_natAdd])] - 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 [Fin.val_natAdd])] - simp only [id_eq] - rw [block_ER_val, block_bigE_val] - simp only [Fin.val_castAdd, Fin.val_natAdd] - split_ifs <;> first - | omega - | (have hk := k.isLt; omega) - · simp only [Bool.not_true, Sum.map_inl, Sum.map_inr, - Bool.false_eq_true, if_false, if_true, reduceIte] - 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 [Fin.val_natAdd])] - 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 [Fin.val_natAdd])] - simp only [id_eq] - rw [block_ER_val, block_bigE_val] - simp only [Fin.val_castAdd, Fin.val_natAdd] - split_ifs <;> first - | omega - | (have hk := k.isLt; omega) + attach_comm := block_splice_bridge_attach_comm K n 𝔊 pairing_comm := by rintro (g | ⟨k, c⟩) · rfl · rfl - circles_eq := by - show 𝔊.circles + (strandBundle K).circles = - (strandBundle K).circles + 𝔊.circles - omega + circles_eq := block_splice_bridge_circles K n 𝔊 /-! ### The splice -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockTower.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockTower.lean index 5784b0eb1b..630111bfac 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockTower.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockTower.lean @@ -167,7 +167,7 @@ private theorem blockPerm_viaEmbedding (n : ℕ) {j k : ℕ} · -- v / n < j: in-range, both sides apply σ -- Simplify τ on q have hτq : (τ ⟨v / n, hqk⟩).val = (σ ⟨v / n, hqj⟩).val := by - show (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ + change (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ ⟨v / n, hqk⟩).val = _ rw [Equiv.Perm.viaEmbeddingHom_apply, show (⟨v / n, hqk⟩ : Fin k) = @@ -202,7 +202,7 @@ private theorem blockPerm_viaEmbedding (n : ℕ) {j k : ℕ} _ = v := Nat.div_add_mod v n -- LHS: τ fixes q have hτq : (τ ⟨v / n, hqk⟩).val = v / n := by - show (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ + change (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ ⟨v / n, hqk⟩).val = _ rw [Equiv.Perm.viaEmbeddingHom_apply, Equiv.Perm.viaEmbedding_apply_of_notMem σ @@ -255,7 +255,7 @@ theorem blockRep_compat (n : ℕ) {j k : ℕ} (h : j ≤ k) (MonoidAlgebra.of ℂ (Equiv.Perm (Fin m)) σ) = MonoidAlgebra.of ℂ (Equiv.Perm (Fin (n * m))) (blockPerm n σ) from by - show MonoidAlgebra.mapDomain (blockPermHom n m) + change MonoidAlgebra.mapDomain (blockPermHom n m) (MonoidAlgebra.single σ 1) = MonoidAlgebra.single (blockPerm n σ) 1 exact MonoidAlgebra.mapDomain_single, @@ -274,7 +274,7 @@ theorem blockRep_compat (n : ℕ) {j k : ℕ} (h : j ≤ k) symCast h' (bLift j (MonoidAlgebra.of ℂ _ σ)) -- LHS: bLift k (of (viaEmbeddingHom (castLEEmb h) σ)) -- = of (blockPerm n (viaEmbeddingHom (castLEEmb h) σ)) - show MonoidAlgebra.mapDomain (blockPermHom n k) + change MonoidAlgebra.mapDomain (blockPermHom n k) (MonoidAlgebra.mapDomain (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h)) (MonoidAlgebra.single σ 1)) = diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleNormal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleNormal.lean index 53c3f64de8..23b6eaae43 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleNormal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleNormal.lean @@ -65,7 +65,7 @@ theorem cycleType_blockCycles (l : List ℕ) -- ...) have key : (blockCycles (c :: rest)).cycleType = (finRotate c).cycleType + (blockCycles rest).cycleType := by - show cycleType (finSumFinEquiv.permCongr + change cycleType (finSumFinEquiv.permCongr (Equiv.sumCongr (finRotate c) (blockCycles rest))) = _ rw [cycleType_permCongr, cycleType_sumCongr] rw [key, ih hrest] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleTrace.lean index 57ce49062e..826e9ca78a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleTrace.lean @@ -43,10 +43,10 @@ theorem catTrace_powHom (X : A) (g : End X) : ∀ n : ℕ, catTrace (powHom X g n) = catTrace g ^ n | 0 => by - show catTrace (𝟙 (𝟙_ A)) = catTrace g ^ 0 + change catTrace (𝟙 (𝟙_ A)) = catTrace g ^ 0 rw [catTrace_id, catDim_unit, pow_zero] | n + 1 => by - show catTrace (powHom X g n ⊗ₘ g) = catTrace g ^ (n + 1) + 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 -/ @@ -116,7 +116,7 @@ private theorem ptr_cycle_step_swapTop private theorem pow_comp_self [Category.{v} A] {X : A} (g : End X) (k : ℕ) : (g ^ (k + 1)) ≫ g = g ^ (k + 2) := by - show (g ^ (k + 1)) ≫ g = g ^ (k + 1 + 1) + change (g ^ (k + 1)) ≫ g = g ^ (k + 1 + 1) rw [pow_succ' g (k + 1)] exact (End.mul_def g (g ^ (k + 1))).symm @@ -140,7 +140,7 @@ theorem catTrace_insertTop_powHom insertTop X n 0 ≫ powHom X g (n + 1) = powHom X g n ⊗ₘ (h ≫ g) := by rw [insertTop_zero] - show (tensorPow A X n ◁ h) ≫ 𝟙 _ ≫ (powHom X g n ⊗ₘ g) = _ + 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 ?_ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvAbelian.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvAbelian.lean index a9aa4e74cf..329b52ce64 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvAbelian.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvAbelian.lean @@ -78,11 +78,11 @@ variable (E : Env f) noncomputable def envTrace : End E →ₗ[ℂ] ℂ where toFun x := matTrace f E.X x.f map_add' x y := by - show matTrace f E.X (x + y).f = _ + 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 - show matTrace f E.X (c • x).f = _ + 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 _ _ @@ -98,10 +98,10 @@ theorem envEnd_isSemisimpleRing : IsSemisimpleRing (End E) := /-- 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 - haveI : HasFiniteBiproducts (Env f) := inferInstance - haveI : HasBinaryBiproducts (Env f) := + have : HasFiniteBiproducts (Env f) := inferInstance + have : HasBinaryBiproducts (Env f) := hasBinaryBiproducts_of_finite_biproducts _ - haveI := envEnd_isSemisimpleRing f (M ⊞ N) + 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))) @@ -231,6 +231,7 @@ theorem env_epi_split {M N : Env f} (e : M ⟶ N) [Epi e] : /-! ### 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 @@ -264,6 +265,7 @@ noncomputable def envNormalMono {M N : Env f} (m : M ⟶ N) [Mono m] : 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDeligne.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDeligne.lean index 934f55548f..504ab2e835 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDeligne.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDeligne.lean @@ -73,7 +73,7 @@ scalars. -/ theorem unitExtract_id : unitExtract f (𝟙 (𝟙_ (Env f))) = HomSpace.ofFragment f.val (strandBundle 0) := by - show ((Karoubi.Hom.f (𝟙 (𝟙_ (Env f))) PUnit.unit + 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))) = @@ -106,7 +106,7 @@ theorem env_endOne : HasScalarUnit (Env f) := by obtain ⟨c, hc⟩ := homSpace_zero_spanned f (unitExtract f x) refine ⟨c, ?_⟩ apply unitExtract_injective f - show c • unitExtract f (𝟙 (𝟙_ (Env f))) = unitExtract f x + change c • unitExtract f (𝟙 (𝟙_ (Env f))) = unitExtract f x rw [unitExtract_id, unit_id_eq_emptyClass] exact hc.symm diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDelignePackage.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDelignePackage.lean index b2758228a4..68cb66ad73 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDelignePackage.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDelignePackage.lean @@ -78,10 +78,10 @@ which the package drops. -/ theorem env_delignePackage (hD : DeligneTheoremStatement.{1, 1}) : Nonempty (DelignePackage (Env f)) := by - letI := envAbelian f + let := envAbelian f exact (hD (Env f) (env_endOne f) ⟨envStrand f 1, env_deligneGenerated f⟩ - (moderateLengthGrowth_of_endGrowth (Env f) + (moderateLengthGrowth_of_endGrowth (Env f) (envAbelian f) (env_deligneSemisimple f) (env_finDimHom f) (env_deligneModerateGrowth f))).map DeligneFibreFunctor.toPackage diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGenerator.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGenerator.lean index e67eece6b0..2956941056 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGenerator.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGenerator.lean @@ -85,22 +85,22 @@ noncomputable def matEmbTensorIso hom_inv_id := by apply Mat_.hom_ext intro i j - haveI : Subsingleton (((Mat_.embedding D).obj x ⊗ + 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] - show ∑ _j : PUnit, 𝟙 (x ⊗ y) ≫ 𝟙 (x ⊗ y) = 𝟙 (x ⊗ y) + change ∑ _j : PUnit, 𝟙 (x ⊗ y) ≫ 𝟙 (x ⊗ y) = 𝟙 (x ⊗ y) simp inv_hom_id := by apply Mat_.hom_ext intro i j - haveI : Subsingleton + 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] - show ∑ _j : PUnit × PUnit, 𝟙 (x ⊗ y) ≫ 𝟙 (x ⊗ y) = + change ∑ _j : PUnit × PUnit, 𝟙 (x ⊗ y) ≫ 𝟙 (x ⊗ y) = 𝟙 (x ⊗ y) simp @@ -146,35 +146,35 @@ object it corners. -/ noncomputable def envAmbientSec (E : Env f) : E ⟶ (toKaroubi (Mat_ (Karoubi (SkeinObj f)))).obj E.X := ⟨E.p, by - show E.p ≫ E.p ≫ 𝟙 E.X = E.p + 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 - show 𝟙 E.X ≫ E.p ≫ E.p = E.p + 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 - show E.p ≫ E.p = E.p + 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 - show x.p ≫ x.p ≫ 𝟙 (SkeinObj.mk x.X.arity) = x.p + 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 - show 𝟙 (SkeinObj.mk x.X.arity) ≫ x.p ≫ x.p = x.p + 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 @@ -182,7 +182,7 @@ envelope. -/ theorem cornerSecK_ret (x : Karoubi (SkeinObj f)) : cornerSecK f x ≫ cornerRetK f x = 𝟙 x := by apply Karoubi.hom_ext - show x.p ≫ x.p = x.p + change x.p ≫ x.p = x.p exact x.idem /-- The embedded corner object of the envelope. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGrowth.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGrowth.lean index 14ef4b0e53..fcb733215d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGrowth.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGrowth.lean @@ -69,7 +69,7 @@ theorem mat_hom_finrank_le (M N : Mat_ (Karoubi (SkeinObj f))) (hN : ∀ j, (N.X j).X.arity ≤ m) : Module.finrank ℂ (M ⟶ N) ≤ Fintype.card M.ι * Fintype.card N.ι * (R + 1) ^ (2 * m) := by - haveI : ∀ p : M.ι × N.ι, Module.Finite ℂ + have : ∀ p : M.ι × N.ι, Module.Finite ℂ (HomSpace f.val ((M.X p.1).X.arity + (N.X p.2).X.arity)) := fun p => inferInstance @@ -130,7 +130,7 @@ theorem mat_pow_arity (A : Mat_ (Karoubi (SkeinObj f))) (m : ℕ) ≤ N * m | 0, p => Nat.le_of_eq (by rw [Nat.zero_mul]; rfl) | N + 1, p => by - show (((tensorPow (Mat_ (Karoubi (SkeinObj f))) A N).X + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvInstances.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvInstances.lean index 0c57056aae..dccc65159b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvInstances.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvInstances.lean @@ -31,25 +31,25 @@ instance skeinMonoidalPreadditive : MonoidalPreadditive (SkeinObj f) where whiskerLeft_zero := by intro X Y Z - show (HomSpace.tensor f X.arity X.arity Y.arity Z.arity + 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 - show (HomSpace.tensor f Y.arity Z.arity X.arity X.arity) 0 + 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' - show (HomSpace.tensor f X.arity X.arity Y.arity Z.arity + 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' - show (HomSpace.tensor f Y.arity Z.arity X.arity X.arity) + change (HomSpace.tensor f Y.arity Z.arity X.arity X.arity) (g + g') (HomSpace.ofFragment f.val (strandBundle X.arity)) = _ rw [map_add] @@ -60,14 +60,14 @@ instance skeinMonoidalLinear : MonoidalLinear ℂ (SkeinObj f) where whiskerLeft_smul := by intro X Y Z c g - show (HomSpace.tensor f X.arity X.arity Y.arity Z.arity + 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 - show (HomSpace.tensor f X.arity Y.arity Z.arity Z.arity) + change (HomSpace.tensor f X.arity Y.arity Z.arity Z.arity) (c • g) (HomSpace.ofFragment f.val (strandBundle Z.arity)) = _ rw [map_smul] @@ -88,22 +88,22 @@ instance karoubiMonoidalPreadditive whiskerLeft_zero := by intro X Y Z apply Karoubi.hom_ext - show X.p ⊗ₘ (0 : Y.X ⟶ Z.X) = 0 + change X.p ⊗ₘ (0 : Y.X ⟶ Z.X) = 0 rw [MonoidalPreadditive.tensor_zero] zero_whiskerRight := by intro X Y Z apply Karoubi.hom_ext - show (0 : Y.X ⟶ Z.X) ⊗ₘ X.p = 0 + 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 - show X.p ⊗ₘ (g.f + g'.f) = X.p ⊗ₘ g.f + X.p ⊗ₘ g'.f + 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 - show (g.f + g'.f) ⊗ₘ X.p = g.f ⊗ₘ X.p + g'.f ⊗ₘ X.p + change (g.f + g'.f) ⊗ₘ X.p = g.f ⊗ₘ X.p + g'.f ⊗ₘ X.p rw [MonoidalPreadditive.add_tensor] /-- And so does monoidal linearity. -/ @@ -113,14 +113,14 @@ instance karoubiMonoidalLinear [Category C] [Preadditive C] [MonoidalCategory C] whiskerLeft_smul := by intro X Y Z c g apply Karoubi.hom_ext - show X.p ⊗ₘ (c • g.f) = c • (X.p ⊗ₘ g.f) + 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 - show (c • g.f) ⊗ₘ Z.p = c • (g.f ⊗ₘ Z.p) + change (c • g.f) ⊗ₘ Z.p = c • (g.f ⊗ₘ Z.p) rw [tensorHom_def, tensorHom_def, MonoidalLinear.smul_whiskerRight, CategoryTheory.Linear.smul_comp] @@ -142,7 +142,7 @@ instance matMonoidalPreadditive intro X Y Z apply Mat_.hom_ext intro ⟨i₁, i₂⟩ ⟨j₁, j₂⟩ - show (𝟙 X : Mat_.Hom X X) i₁ 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] @@ -151,7 +151,7 @@ instance matMonoidalPreadditive intro X Y Z apply Mat_.hom_ext intro ⟨i₁, i₂⟩ ⟨j₁, j₂⟩ - show (0 : Y ⟶ Z) i₁ 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] @@ -160,7 +160,7 @@ instance matMonoidalPreadditive intro X Y Z g g' apply Mat_.hom_ext intro i j - show (𝟙 X : Mat_.Hom X X) i.1 j.1 ⊗ₘ + 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, @@ -170,7 +170,7 @@ instance matMonoidalPreadditive intro X Y Z g g' apply Mat_.hom_ext intro ⟨i₁, i₂⟩ ⟨j₁, j₂⟩ - show (g + g' : Mat_.Hom Y Z) i₁ 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, @@ -195,11 +195,11 @@ noncomputable instance matHomModule' smul_zero c := by funext i j; exact smul_zero c smul_add c φ ψ := by funext i j - show c • (φ i j + ψ i j) = c • φ i j + c • ψ 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 - show (c + d) • φ i j = c • φ i j + d • φ 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) @@ -209,13 +209,13 @@ noncomputable instance matLinear' CategoryTheory.Linear ℂ (Mat_ C) where smul_comp M N K c φ ψ := by funext i k - show ∑ j, (c • φ i j) ≫ ψ j k = c • ∑ j, φ i j ≫ ψ j 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 - show ∑ j, φ i j ≫ (c • ψ j k) = c • ∑ j, φ i j ≫ ψ j 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] @@ -249,7 +249,7 @@ instance matMonoidalLinear [Category C] [Preadditive C] [MonoidalCategory C] intro X Y Z c g apply Mat_.hom_ext intro i j - show (𝟙 X : Mat_.Hom X X) i.1 j.1 ⊗ₘ + 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 _ @@ -257,7 +257,7 @@ instance matMonoidalLinear [Category C] [Preadditive C] [MonoidalCategory C] intro c X Y g Z apply Mat_.hom_ext intro i j - show (c • g i.1 j.1) ⊗ₘ + 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 _ _ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvSemisimple.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvSemisimple.lean index 464e6171d6..546a2aaeca 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvSemisimple.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvSemisimple.lean @@ -45,7 +45,7 @@ noncomputable def cornerIncl [Category.{v} D] (X : Karoubi D) {e : End X} (he : IsIdempotentElem e) : karoubiCorner X he ⟶ X := ⟨e.f, by - show e.f ≫ e.f ≫ X.p = e.f + change e.f ≫ e.f ≫ X.p = e.f rw [Karoubi.comp_p] exact congrArg Karoubi.Hom.f he⟩ @@ -54,7 +54,7 @@ noncomputable def cornerProj [Category.{v} D] (X : Karoubi D) {e : End X} (he : IsIdempotentElem e) : X ⟶ karoubiCorner X he := ⟨e.f, by - show X.p ≫ e.f ≫ e.f = e.f + 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]⟩ @@ -64,7 +64,7 @@ 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 - show e.f ≫ e.f = e.f + change e.f ≫ e.f = e.f exact congrArg Karoubi.Hom.f he /-- Projecting then including is the idempotent. -/ @@ -79,7 +79,7 @@ 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 - show e.f ≫ e.f = e.f + change e.f ≫ e.f = e.f exact congrArg Karoubi.Hom.f he /-- And so is the projection. -/ @@ -87,7 +87,7 @@ 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 - show e.f ≫ e.f = e.f + change e.f ≫ e.f = e.f exact congrArg Karoubi.Hom.f he /-- Cross-composites of distinct orthogonal corners vanish. -/ @@ -98,7 +98,7 @@ theorem cornerIncl_proj_orthogonal (horth : e' * e = 0) : cornerIncl X he ≫ cornerProj X he' = 0 := by apply Karoubi.hom_ext - show e.f ≫ e'.f = (0 : X.X ⟶ X.X) + change e.f ≫ e'.f = (0 : X.X ⟶ X.X) exact congrArg Karoubi.Hom.f horth end GenericCut @@ -138,7 +138,6 @@ theorem env_simple_of_scalar_end (E : Env f) (hne : 𝟙 E ≠ 0) 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 @@ -198,8 +197,8 @@ theorem env_deligneSemisimple : IsSemisimple (Env f) := by classical intro E - haveI : FiniteDimensional ℂ (End E) := envHomFinite f E E - haveI := envEnd_isSemisimpleRing f 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`. @@ -231,8 +230,8 @@ theorem env_deligneSemisimple : rw [biproduct.ι_desc_assoc, biproduct.ι_π] by_cases hij : i = j · subst hij - rw [dif_pos rfl, eqToHom_refl, cornerIncl_proj] - · rw [dif_neg 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)) } diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/Frobenius.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/Frobenius.lean index f8df78ea10..d116d6131a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/Frobenius.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/Frobenius.lean @@ -41,8 +41,8 @@ private theorem permHighEquiv_eq_outMapEquiv {t : ℕ} by_cases hx : x.val < t · -- Low label: both are the identity have h1 : (permHighEquiv σ x).val = x.val := by - show (if h : x.val < t then x else _).val = x.val - rw [dif_pos hx] + 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] @@ -51,10 +51,10 @@ private theorem permHighEquiv_eq_outMapEquiv {t : ℕ} have hxt := x.isLt have h1 : (permHighEquiv σ x).val = t + (σ ⟨x.val - t, by omega⟩).val := by - show (if h : x.val < t then x else _).val = _ - rw [dif_neg hx] + 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 show x.val = t + (x.val - t); 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] @@ -65,7 +65,7 @@ private theorem permHighEquiv_eq_outMapEquiv {t : ℕ} theorem permClass_eq_bundleMapClass (n : ℕ) (σ : Equiv.Perm (Fin n)) : permClass f n σ = bundleMapClass f σ := by - show HomSpace.ofFragment f.val (permFragment σ) = + change HomSpace.ofFragment f.val (permFragment σ) = HomSpace.ofFragment f.val (bundleMap σ) exact HomSpace.ofFragment_congr f ((permFragmentRelabelBundle σ).trans @@ -81,7 +81,7 @@ private theorem permCongr_sumCongr_eq_tensorMapEquiv finSumFinEquiv.permCongr (Equiv.sumCongr σ τ) = tensorMapEquiv σ τ := by refine _root_.Equiv.ext (fun x => Fin.ext ?_) - show (finSumFinEquiv ((Equiv.sumCongr σ τ) + change (finSumFinEquiv ((Equiv.sumCongr σ τ) (finSumFinEquiv.symm x))).val = (tensorMapEquiv σ τ x).val unfold tensorMapEquiv @@ -100,7 +100,7 @@ theorem permClass_sumCongr (a b : ℕ) (σ : Equiv.Perm (Fin a)) End (SkeinObj.mk (a + b))) := by rw [permClass_eq_bundleMapClass, permCongr_sumCongr_eq_tensorMapEquiv] - show bundleMapClass f (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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiEmbBraided.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiEmbBraided.lean index 1d91d59a9d..c01fd970e5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiEmbBraided.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiEmbBraided.lean @@ -45,12 +45,12 @@ noncomputable instance toKaroubiBraided Functor.Braided (toKaroubi C) where braided X Y := by apply Karoubi.hom_ext - show (Functor.LaxMonoidal.μ (toKaroubi C) X Y).f ≫ + 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] - show 𝟙 (X ⊗ Y) ≫ (β_ X Y).hom = + change 𝟙 (X ⊗ Y) ≫ (β_ X Y).hom = ((𝟙 X ⊗ₘ 𝟙 Y) ≫ (β_ X Y).hom) ≫ 𝟙 (Y ⊗ X) simp diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiRigid.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiRigid.lean index 70d92031a8..41c08f3920 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiRigid.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiRigid.lean @@ -262,20 +262,21 @@ theorem karoubi_snake_two /-! ### 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 - show 𝟙 (𝟙_ C) ≫ (η_ P.X (P.X)ᘁ ≫ (P.p ⊗ₘ (P.p)ᘁ)) ≫ + 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 - show ((P.p)ᘁ ⊗ₘ P.p) ≫ + 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] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiSemisimple.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiSemisimple.lean index 47390c4153..0c9cc7e12e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiSemisimple.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiSemisimple.lean @@ -51,7 +51,7 @@ 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 - haveI : FiniteDimensional ℂ (End X.X) := + 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 @@ -82,7 +82,7 @@ theorem karoubiHom_eq_zero_of_traces_vanish HomSpace.traceMap f.val X.X.arity (a.f ≫ b.f) = 0) : a = 0 := by apply Karoubi.hom_ext - show a.f = 0 + 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 = diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean index 6857378bb7..e66aef27f5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean @@ -18,7 +18,7 @@ noncomputable section namespace RS -open scoped Classical + open CategoryTheory CategoryTheory.Category CategoryTheory.MonoidalCategory open CategoryTheory.Limits CategoryTheory.MonoidalPreadditive @@ -50,6 +50,7 @@ variable {C : Type u} : (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) @@ -60,6 +61,7 @@ variable {C : Type u} (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) @@ -74,6 +76,7 @@ variable {C : Type u} section Braided +open scoped Classical in private def matBraidHom [Category.{v} C] [Preadditive C] [MonoidalCategory C] [BraidedCategory C] (M N : Mat_ C) : (M ⊗ N : Mat_ C) ⟶ (N ⊗ M : Mat_ C) := @@ -84,6 +87,7 @@ private def matBraidHom [Category.{v} C] [Preadditive C] [MonoidalCategory C] else 0 else 0 +open scoped Classical in private def matBraidInv [Category.{v} C] [Preadditive C] [MonoidalCategory C] [BraidedCategory C] (M N : Mat_ C) : (N ⊗ M : Mat_ C) ⟶ (M ⊗ N : Mat_ C) := @@ -94,6 +98,7 @@ private def matBraidInv [Category.{v} C] [Preadditive C] [MonoidalCategory C] else 0 else 0 +open scoped Classical in @[simp] private theorem matBraidHom_apply [Category.{v} C] [Preadditive C] [MonoidalCategory C] [BraidedCategory C] @@ -104,6 +109,7 @@ private def matBraidInv [Category.{v} C] [Preadditive C] [MonoidalCategory C] 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] @@ -441,7 +447,7 @@ instance matSymmetric [Category.{v} C] [Preadditive C] [MonoidalCategory C] [MonoidalPreadditive C] [SymmetricCategory C] : SymmetricCategory (Mat_ C) where symmetry X Y := by - show matBraidHom X Y ≫ matBraidHom Y X = 𝟙 _ + 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] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean index c2e596e12c..14d40bccb9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean @@ -30,7 +30,7 @@ noncomputable section namespace RS -open scoped Classical + open CategoryTheory CategoryTheory.Category CategoryTheory.MonoidalCategory open CategoryTheory.Limits CategoryTheory.Idempotents @@ -76,22 +76,22 @@ private theorem matEmb_μ_natural_left ∑ k, matEmbTensorHom X X' i k ≫ (Mat_.embedding C).map (f ▷ X') k j := rfl rw [hL, hR] - haveI : Subsingleton ((Mat_.embedding C).obj Y ⊗ (Mat_.embedding C).obj X').ι + have : Subsingleton ((Mat_.embedding C).obj Y ⊗ (Mat_.embedding C).obj X').ι := inferInstanceAs (Subsingleton (PUnit × PUnit)) - haveI : Subsingleton ((Mat_.embedding C).obj (X ⊗ X')).ι := + 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] - show (f ⊗ₘ (𝟙 ((Mat_.embedding C).obj X') : Mat_.Hom _ _) i.2 a.2) ≫ 𝟙 (Y ⊗ + change (f ⊗ₘ (𝟙 ((Mat_.embedding C).obj X') : Mat_.Hom _ _) i.2 a.2) ≫ 𝟙 (Y ⊗ X') = 𝟙 (X ⊗ X') ≫ (f ▷ X') - haveI : Subsingleton ((Mat_.embedding C).obj X').ι := inferInstanceAs + have : Subsingleton ((Mat_.embedding C).obj X').ι := inferInstanceAs (Subsingleton PUnit) rw [show i.2 = a.2 from Subsingleton.elim _ _, Mat_.id_apply_self] - show (f ⊗ₘ 𝟙 X') ≫ 𝟙 (Y ⊗ X') = 𝟙 (X ⊗ X') ≫ (f ▷ X') + change (f ⊗ₘ 𝟙 X') ≫ 𝟙 (Y ⊗ X') = 𝟙 (X ⊗ X') ≫ (f ▷ X') rw [tensorHom_id, comp_id, id_comp] private theorem matEmb_μ_natural_right @@ -109,27 +109,28 @@ private theorem matEmb_μ_natural_right ∑ k, matEmbTensorHom X' X i k ≫ (Mat_.embedding C).map (X' ◁ f) k j := rfl rw [hL, hR] - haveI : Subsingleton ((Mat_.embedding C).obj X' ⊗ (Mat_.embedding C).obj Y).ι + have : Subsingleton ((Mat_.embedding C).obj X' ⊗ (Mat_.embedding C).obj Y).ι := inferInstanceAs (Subsingleton (PUnit × PUnit)) - haveI : Subsingleton ((Mat_.embedding C).obj (X' ⊗ X)).ι := + 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] - show ((𝟙 ((Mat_.embedding C).obj X') : Mat_.Hom _ _) i.1 a.1 ⊗ₘ f) ≫ 𝟙 (X' ⊗ + change ((𝟙 ((Mat_.embedding C).obj X') : Mat_.Hom _ _) i.1 a.1 ⊗ₘ f) ≫ 𝟙 (X' ⊗ Y) = 𝟙 (X' ⊗ X) ≫ (X' ◁ f) - haveI : Subsingleton ((Mat_.embedding C).obj X').ι := inferInstanceAs + have : Subsingleton ((Mat_.embedding C).obj X').ι := inferInstanceAs (Subsingleton PUnit) rw [show i.1 = a.1 from Subsingleton.elim _ _, Mat_.id_apply_self] - show (𝟙 X' ⊗ₘ f) ≫ 𝟙 (X' ⊗ Y) = 𝟙 (X' ⊗ X) ≫ (X' ◁ f) + 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) @@ -152,11 +153,11 @@ private theorem matEmb_associativity (Mat_.embedding C).obj X ◁ matEmbTensorHom Y Z ≫ matEmbTensorHom X (Y ⊗ Z) := by apply Mat_.hom_ext; intro i j - haveI : Subsingleton ((Mat_.embedding C).obj X).ι := inferInstanceAs + have : Subsingleton ((Mat_.embedding C).obj X).ι := inferInstanceAs (Subsingleton PUnit) - haveI : Subsingleton ((Mat_.embedding C).obj Y).ι := inferInstanceAs + have : Subsingleton ((Mat_.embedding C).obj Y).ι := inferInstanceAs (Subsingleton PUnit) - haveI : Subsingleton ((Mat_.embedding C).obj Z).ι := inferInstanceAs + 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 ≫ @@ -168,7 +169,7 @@ private theorem matEmb_associativity (matEmbTensorHom (X ⊗ Y) Z ≫ (Mat_.embedding C).map (α_ X Y Z).hom) k j := rfl rw [h1] - haveI : Subsingleton ((Mat_.embedding C).obj (X ⊗ Y) ⊗ (Mat_.embedding + 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).ι := @@ -179,15 +180,15 @@ private theorem matEmb_associativity ∑ k, matEmbTensorHom (X ⊗ Y) Z a1 k ≫ (Mat_.embedding C).map (α_ X Y Z).hom k j := rfl rw [h2] - haveI : Subsingleton ((Mat_.embedding C).obj ((X ⊗ Y) ⊗ Z)).ι := + 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] - show (matEmbTensorHom X Y i.1 a1.1 ⊗ₘ (𝟙 ((Mat_.embedding C).obj Z)) i.2 + 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] - show (𝟙 (X ⊗ Y) ⊗ₘ 𝟙 Z) ≫ 𝟙 ((X ⊗ Y) ⊗ Z) ≫ (α_ X Y Z).hom = (α_ X Y Z).hom + 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) @@ -204,7 +205,7 @@ private theorem matEmb_associativity ((Mat_.embedding C).obj X ◁ matEmbTensorHom Y Z ≫ matEmbTensorHom X (Y ⊗ Z)) k j := rfl rw [h1] - haveI : Subsingleton ((Mat_.embedding C).obj X ⊗ + 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 ⊗ @@ -216,7 +217,7 @@ private theorem matEmb_associativity ∑ k, ((Mat_.embedding C).obj X ◁ matEmbTensorHom Y Z) a2 k ≫ matEmbTensorHom X (Y ⊗ Z) k j := rfl rw [h2] - haveI : Subsingleton ((Mat_.embedding C).obj X ⊗ + 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)).ι := @@ -228,24 +229,25 @@ private theorem matEmb_associativity 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', - dif_pos (Subsingleton.elim i.1.1 a2.1), - dif_pos (Subsingleton.elim i.1.2 a2.2.1), - dif_pos (Subsingleton.elim i.2 a2.2.2)] + 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 - show (α_ 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] - show (α_ X Y Z).hom ≫ (𝟙 X ⊗ₘ 𝟙 (Y ⊗ Z)) ≫ 𝟙 (X ⊗ (Y ⊗ Z)) = (α_ X Y Z).hom + 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.ι) : @@ -253,6 +255,7 @@ private theorem mat_leftUnitorHom_apply' 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 @@ -273,16 +276,16 @@ private theorem matEmb_left_unitality matEmbTensorHom (𝟙_ C) X ≫ (Mat_.embedding C).map (λ_ X).hom := by apply Mat_.hom_ext; intro i j - haveI : Subsingleton ((Mat_.embedding C).obj (𝟙_ C)).ι := + have : Subsingleton ((Mat_.embedding C).obj (𝟙_ C)).ι := inferInstanceAs (Subsingleton PUnit) - haveI : Subsingleton ((Mat_.embedding C).obj X).ι := + have : Subsingleton ((Mat_.embedding C).obj X).ι := inferInstanceAs (Subsingleton PUnit) - haveI : Subsingleton (𝟙_ (Mat_ C)).ι := + 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', - dif_pos (Subsingleton.elim i.2 j)] + dite_eq_left (Subsingleton.elim i.2 j)] erw [eqToHom_refl, id_comp]; rfl -- RHS = (λ_ X).hom have hRHS : ((𝟙 ((Mat_.embedding C).obj (𝟙_ C)) : @@ -301,7 +304,7 @@ private theorem matEmb_left_unitality (matEmbTensorHom (𝟙_ C) X ≫ (Mat_.embedding C).map (λ_ X).hom) k j := rfl rw [h1] - haveI : Subsingleton ((Mat_.embedding C).obj (𝟙_ C) ⊗ (Mat_.embedding C).obj + 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).ι := @@ -312,16 +315,16 @@ private theorem matEmb_left_unitality ∑ k, matEmbTensorHom (𝟙_ C) X a k ≫ (Mat_.embedding C).map (λ_ X).hom k j := rfl rw [h2] - haveI : Subsingleton ((Mat_.embedding C).obj (𝟙_ C ⊗ X)).ι := + 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] - show ((𝟙 ((Mat_.embedding C).obj (𝟙_ C)) : Mat_.Hom _ _) i.1 a.1 ⊗ₘ + 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] - show (𝟙 (𝟙_ C) ⊗ₘ 𝟙 X) ≫ 𝟙 (𝟙_ C ⊗ X) ≫ (λ_ X).hom = (λ_ X).hom + change (𝟙 (𝟙_ C) ⊗ₘ 𝟙 X) ≫ 𝟙 (𝟙_ C ⊗ X) ≫ (λ_ X).hom = (λ_ X).hom rw [MonoidalCategory.id_tensorHom_id, id_comp, id_comp] rw [hLHS, hRHS] @@ -336,15 +339,15 @@ private theorem matEmb_right_unitality matEmbTensorHom X (𝟙_ C) ≫ (Mat_.embedding C).map (ρ_ X).hom := by apply Mat_.hom_ext; intro i j - haveI : Subsingleton ((Mat_.embedding C).obj X).ι := inferInstanceAs + have : Subsingleton ((Mat_.embedding C).obj X).ι := inferInstanceAs (Subsingleton PUnit) - haveI : Subsingleton ((Mat_.embedding C).obj (𝟙_ C)).ι := + have : Subsingleton ((Mat_.embedding C).obj (𝟙_ C)).ι := inferInstanceAs (Subsingleton PUnit) - haveI : Subsingleton (𝟙_ (Mat_ 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', - dif_pos (Subsingleton.elim i.1 j)] + dite_eq_left (Subsingleton.elim i.1 j)] erw [eqToHom_refl, id_comp]; rfl -- RHS = (ρ_ X).hom have hRHS : ((Mat_.embedding C).obj X ◁ @@ -363,7 +366,7 @@ private theorem matEmb_right_unitality (matEmbTensorHom X (𝟙_ C) ≫ (Mat_.embedding C).map (ρ_ X).hom) k j := rfl rw [h1] - haveI : Subsingleton ((Mat_.embedding C).obj X ⊗ (Mat_.embedding C).obj (𝟙_ + 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)).ι := @@ -374,16 +377,16 @@ private theorem matEmb_right_unitality ∑ k, matEmbTensorHom X (𝟙_ C) a k ≫ (Mat_.embedding C).map (ρ_ X).hom k j := rfl rw [h2] - haveI : Subsingleton ((Mat_.embedding C).obj (X ⊗ 𝟙_ C)).ι := + 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] - show ((𝟙 ((Mat_.embedding C).obj X) : Mat_.Hom _ _) i.1 a.1 ⊗ₘ + 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] - show (𝟙 X ⊗ₘ 𝟙 (𝟙_ C)) ≫ 𝟙 (X ⊗ 𝟙_ C) ≫ (ρ_ X).hom = (ρ_ X).hom + change (𝟙 X ⊗ₘ 𝟙 (𝟙_ C)) ≫ 𝟙 (X ⊗ 𝟙_ C) ≫ (ρ_ X).hom = (ρ_ X).hom rw [MonoidalCategory.id_tensorHom_id, id_comp, id_comp] rw [hLHS, hRHS] @@ -418,6 +421,7 @@ noncomputable instance matEmbeddingMonoidal 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] @@ -439,13 +443,13 @@ private theorem matEmb_braided (β_ ((Mat_.embedding C).obj X) ((Mat_.embedding C).obj Y)).hom ≫ Functor.LaxMonoidal.μ (Mat_.embedding C) Y X := by -- μ is matEmbTensorHom by CoreMonoidal construction - show matEmbTensorHom X Y ≫ (Mat_.embedding C).map (β_ X Y).hom = + 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 - haveI : Subsingleton ((Mat_.embedding C).obj X).ι := inferInstanceAs + have : Subsingleton ((Mat_.embedding C).obj X).ι := inferInstanceAs (Subsingleton PUnit) - haveI : Subsingleton ((Mat_.embedding C).obj Y).ι := inferInstanceAs + 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 = @@ -454,11 +458,11 @@ private theorem matEmb_braided ∑ k, matEmbTensorHom X Y i k ≫ (Mat_.embedding C).map (β_ X Y).hom k j := rfl rw [h1] - haveI : Subsingleton ((Mat_.embedding C).obj (X ⊗ Y)).ι := + 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] - show 𝟙 (X ⊗ Y) ≫ (β_ X Y).hom = (β_ X Y).hom + 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 ≫ @@ -468,7 +472,7 @@ private theorem matEmb_braided ∑ k, (β_ ((Mat_.embedding C).obj X) ((Mat_.embedding C).obj Y)).hom i k ≫ matEmbTensorHom Y X k j := rfl rw [h1] - haveI : Subsingleton ((Mat_.embedding C).obj Y ⊗ (Mat_.embedding C).obj X).ι + 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).ι := @@ -482,11 +486,11 @@ private theorem matEmb_braided erw [show i = (i.1, i.2) from rfl, show b = (b.1, b.2) from rfl, mat_braidHom_apply', - dif_pos (Subsingleton.elim i.2 b.1), - dif_pos (Subsingleton.elim i.1 b.2)] + 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] - show (β_ X Y).hom ≫ 𝟙 (Y ⊗ X) = (β_ X Y).hom + change (β_ X Y).hom ≫ 𝟙 (Y ⊗ X) = (β_ X Y).hom rw [comp_id] rw [hLHS, hRHS] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean index f9b3cf9c57..30741cbc27 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean @@ -31,7 +31,7 @@ noncomputable section namespace RS -open scoped Classical + open CategoryTheory CategoryTheory.Category CategoryTheory.MonoidalCategory open CategoryTheory.Limits CategoryTheory.MonoidalPreadditive @@ -64,6 +64,7 @@ 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`. -/ private def matAssocHom [Category.{v} C] [Preadditive C] [MonoidalCategory C] (M N K : Mat_ C) : @@ -78,6 +79,7 @@ private def matAssocHom [Category.{v} C] [Preadditive C] [MonoidalCategory C] else 0 else 0 +open scoped Classical in /-- The associator inv in `Mat_ C`. -/ private def matAssocInv [Category.{v} C] [Preadditive C] [MonoidalCategory C] (M N K : Mat_ C) : @@ -92,6 +94,7 @@ private def matAssocInv [Category.{v} C] [Preadditive C] [MonoidalCategory C] else 0 else 0 +open scoped Classical in /-- The left unitor hom in `Mat_ C`. -/ private def matLeftUnitorHom [Category.{v} C] [Preadditive C] [MonoidalCategory C] @@ -102,6 +105,7 @@ private def matLeftUnitorHom eqToHom (by subst h; rfl) ≫ (λ_ (M.X j)).hom else 0 +open scoped Classical in /-- The left unitor inv in `Mat_ C`. -/ private def matLeftUnitorInv [Category.{v} C] [Preadditive C] [MonoidalCategory C] @@ -112,6 +116,7 @@ private def matLeftUnitorInv (λ_ (M.X i)).inv ≫ eqToHom (by subst h; rfl) else 0 +open scoped Classical in /-- The right unitor hom in `Mat_ C`. -/ private def matRightUnitorHom [Category.{v} C] [Preadditive C] [MonoidalCategory C] @@ -122,6 +127,7 @@ private def matRightUnitorHom eqToHom (by subst h; rfl) ≫ (ρ_ (M.X j)).hom else 0 +open scoped Classical in /-- The right unitor inv in `Mat_ C`. -/ private def matRightUnitorInv [Category.{v} C] [Preadditive C] [MonoidalCategory C] @@ -138,6 +144,7 @@ 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) : @@ -162,6 +169,7 @@ private theorem matAssoc_hom_inv · 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) : @@ -184,6 +192,7 @@ private theorem matAssoc_inv_hom · 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) : @@ -200,6 +209,7 @@ private theorem matLeftUnitor_hom_inv 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) : @@ -216,6 +226,7 @@ private theorem matLeftUnitor_inv_hom 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) : @@ -233,6 +244,7 @@ private theorem matRightUnitor_hom_inv 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) : @@ -329,6 +341,7 @@ private theorem mat_tensorHom_comp 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} @@ -357,6 +370,7 @@ private theorem mat_associator_naturality · 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) : @@ -375,6 +389,7 @@ private theorem mat_leftUnitor_naturality 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) : @@ -404,6 +419,7 @@ gone both sides reduce to the corresponding coherence in `C`. -/ -- Raised budget: 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] @@ -460,6 +476,7 @@ private theorem mat_pentagon · 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] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean index 5b9ed3aea6..5e8c0707a3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean @@ -24,7 +24,7 @@ noncomputable section namespace RS -open scoped Classical + open CategoryTheory CategoryTheory.Category CategoryTheory.MonoidalCategory open CategoryTheory.Limits CategoryTheory.MonoidalPreadditive @@ -52,6 +52,7 @@ so we restate the ones we need. Each is proved by `rfl`. -/ (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) @@ -62,6 +63,7 @@ so we restate the ones we need. Each is proved by `rfl`. -/ (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) @@ -72,6 +74,7 @@ so we restate the ones we need. Each is proved by `rfl`. -/ (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 : @@ -80,6 +83,7 @@ so we restate the ones we need. Each is proved by `rfl`. -/ 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 : @@ -88,6 +92,7 @@ so we restate the ones we need. Each is proved by `rfl`. -/ 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 : @@ -96,6 +101,7 @@ so we restate the ones we need. Each is proved by `rfl`. -/ 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 : @@ -114,6 +120,7 @@ so we restate the ones we need. Each is proved by `rfl`. -/ /-! ### 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] @@ -123,6 +130,7 @@ noncomputable def matCoev [Category.{v} C] [Preadditive C] [MonoidalCategory C] 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] @@ -147,7 +155,7 @@ private theorem matCoev_apply_off (M : Mat_ C) (u : PUnit) (i j : M.ι) (h : i ≠ j) : matCoev M u (i, j) = 0 := - dif_neg h + dite_eq_right h private theorem matEv_apply_diag [Category.{v} C] [Preadditive C] [MonoidalCategory C] @@ -162,7 +170,7 @@ private theorem matEv_apply_off (M : Mat_ C) (i j : M.ι) (u : PUnit) (h : i ≠ j) : matEv M (i, j) u = 0 := - dif_neg h + dite_eq_right h /-! ### The snake identities -/ @@ -206,7 +214,7 @@ private theorem mat_snake_one eqToHom_refl, id_comp, comp_id] exact ExactPairing.coevaluation_evaluation (M.X a) ((M.X a)ᘁ) · intro c _ hc - rw [mat_rightUnitorHom_apply', dif_neg (Ne.symm 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] @@ -216,7 +224,7 @@ private theorem mat_snake_one mat_leftUnitorInv_apply'] simp [hab] · intro c _ hc - rw [mat_rightUnitorHom_apply', dif_neg (Ne.symm hc), + rw [mat_rightUnitorHom_apply', dite_eq_right (Ne.symm hc), zero_comp] · intro l' _ hl' simp [Ne.symm hl', zero_comp] @@ -303,7 +311,7 @@ private theorem mat_snake_two eqToHom_refl, id_comp, comp_id] exact ExactPairing.evaluation_coevaluation (M.X a) ((M.X a)ᘁ) · intro c _ hc - rw [mat_leftUnitorHom_apply', dif_neg (Ne.symm hc), zero_comp] + 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, @@ -312,7 +320,7 @@ private theorem mat_snake_two mat_rightUnitorInv_apply'] simp [hab] · intro c _ hc - rw [mat_leftUnitorHom_apply', dif_neg (Ne.symm hc), zero_comp] + rw [mat_leftUnitorHom_apply', dite_eq_right (Ne.symm hc), zero_comp] · intro l' _ hl' simp [Ne.symm hl', zero_comp] · intro k' _ hk' @@ -371,6 +379,7 @@ private theorem mat_snake_two /-! ### 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] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatSemisimple.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatSemisimple.lean index 9459c39603..8ece39fa1d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatSemisimple.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatSemisimple.lean @@ -37,11 +37,11 @@ noncomputable instance matHomModule smul_zero c := by funext i j; exact smul_zero c smul_add c φ ψ := by funext i j - show c • (φ i j + ψ i j) = c • φ i j + c • ψ 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 - show (c + d) • φ i j = c • φ i j + d • φ 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) @@ -50,13 +50,13 @@ noncomputable instance matLinear : CategoryTheory.Linear ℂ (Mat_ (Karoubi (SkeinObj f))) where smul_comp M N K c φ ψ := by funext i k - show ∑ j, (c • φ i j) ≫ ψ j k = c • ∑ j, φ i j ≫ ψ j 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 - show ∑ j, φ i j ≫ (c • ψ j k) = c • ∑ j, φ i j ≫ ψ j 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] @@ -90,7 +90,7 @@ private theorem karoubi_trace_comm theorem matTrace_comp_comm {M N : Mat_ (Karoubi (SkeinObj f))} (α : M ⟶ N) (β : N ⟶ M) : matTrace f M (α ≫ β) = matTrace f N (β ≫ α) := by - show (∑ i : M.ι, HomSpace.traceMap f.val (M.X i).X.arity + 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 @@ -150,7 +150,7 @@ private theorem matTrace_matSingle_mul HomSpace.traceMap f.val (M.X i).X.arity ((φ i j).f ≫ b.f) := by classical - show (∑ k : M.ι, HomSpace.traceMap f.val (M.X k).X.arity + 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 @@ -164,7 +164,7 @@ private theorem matTrace_matSingle_mul rw [Finset.sum_eq_zero, map_zero] intro l _ rw [show matSingle f j i b l k = 0 from - dif_neg (fun h => hk h.2)] + 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] @@ -181,7 +181,7 @@ private theorem matTrace_matSingle_mul rw [Finset.sum_eq_single j (fun l _ hl => by rw [show matSingle f j i b l i = 0 from - dif_neg (fun h => hl h.1)] + 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] @@ -190,7 +190,7 @@ private theorem matTrace_matSingle_mul (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 dif_pos ⟨rfl, rfl⟩] + eqToHom (congrArg M.X rfl) from dite_eq_left ⟨rfl, rfl⟩] rw [eqToHom_refl, eqToHom_refl, Category.comp_id, Category.id_comp] rfl @@ -202,7 +202,7 @@ theorem matEnd_eq_zero_of_traces_vanish φ = 0 := by apply Mat_.hom_ext intro i j - show φ i j = 0 + 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) @@ -216,7 +216,7 @@ the skein hom-spaces. -/ noncomputable instance karoubiHomFinite (P Q : Karoubi (SkeinObj f)) : FiniteDimensional ℂ (P ⟶ Q) := by - haveI : FiniteDimensional ℂ (P.X ⟶ Q.X) := + 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentMatTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentMatTrace.lean index d2a52653db..0b44d7250a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentMatTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentMatTrace.lean @@ -62,7 +62,7 @@ theorem karoubiTrace_split {X : Karoubi (SkeinObj f)} ((e a).f ≫ x.f)).trans (congrArg (HomSpace.traceMap f.val X.X.arity) (by - show ((e a).f ≫ x.f) ≫ (e a).f = + change ((e a).f ≫ x.f) ≫ (e a).f = (e a).f ≫ x.f ≫ (e a).f exact Category.assoc _ _ _)) @@ -89,8 +89,8 @@ noncomputable def atomResolution (e : ι → End (M.X i)), CompleteOrthogonalIdempotents e ∧ ∀ a, IsAtomicIdempotent (e a) := fun i => by - haveI := karoubiEndFinite f (M.X i) - haveI := karoubiEnd_isSemisimpleRing f (M.X i) + 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⟩ @@ -258,7 +258,7 @@ noncomputable def AtomResolution.w (A : AtomResolution f M) 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 - show (A.e p.1 p.2).f ≫ ((A.e p.1 p.2).f ≫ + 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 ≫ @@ -405,12 +405,12 @@ noncomputable def AtomResolution.B (φ : End M) : 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 := - dif_neg h + 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 - show A.B 0 p q = 0 + 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 @@ -438,7 +438,7 @@ theorem AtomResolution.B_comp (φ ψ : End M) : 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 dif_pos h] + 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 : @@ -473,12 +473,12 @@ theorem AtomResolution.B_comp (φ ψ : End M) : · 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 dif_pos hq] + 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 dif_pos hqr] + 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] @@ -549,7 +549,7 @@ theorem AtomResolution.trace_t_diag (φ : End M) (p : A.κ) : 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)))) := dif_pos rfl + 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 _ _, diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/PermTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/PermTrace.lean index 2f31ded0d6..8183b26824 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/PermTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/PermTrace.lean @@ -156,7 +156,7 @@ theorem catTrace_blockCycles powHom X g l.sum) = (l.map (fun c => catTrace (g ^ c))).prod | [], _ => by - show catTrace (permMor X 0 1 ≫ powHom X g 0) = 1 + 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 @@ -165,7 +165,7 @@ theorem catTrace_blockCycles ⟨c - 1, by have := hmem c (by simp); omega⟩ have hrest : ∀ d ∈ rest, 1 ≤ d := fun d hd => hmem d (by simp [hd]) - show catTrace (permMor X ((m + 1) + rest.sum) + 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, diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarPermTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarPermTrace.lean index 141ab837e0..02a7fb7b66 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarPermTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarPermTrace.lean @@ -36,7 +36,7 @@ theorem scalarTrace_permMor_powHom (permMor X n π ≫ powHom X g n) = ((fullCycleType π).map (fun c => scalarTrace hu X (g ^ c))).prod := by - show unitScalar hu (catTrace (permMor X n π ≫ powHom X g n)) = _ + change unitScalar hu (catTrace (permMor X n π ≫ powHom X g n)) = _ rw [catTrace_permMor_powHom, map_multiset_prod, Multiset.map_map] rfl diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarTrace.lean index abd589b3c5..5e8ed1533b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarTrace.lean @@ -62,7 +62,7 @@ theorem scalarTrace_comp_comm (h : HasScalarUnit C) {X Y : C} (f : X ⟶ Y) (g : Y ⟶ X) : scalarTrace h X (f ≫ g) = scalarTrace h Y (g ≫ f) := by - show unitScalar h (catTrace (f ≫ g)) = unitScalar h (catTrace (g ≫ f)) + 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/SkeinDimBound.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinDimBound.lean index 7bdb8a4db5..fd457862e2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinDimBound.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinDimBound.lean @@ -32,10 +32,10 @@ open Finset /-- The chosen block dimension is positive. -/ theorem jtSimple_dim_pos (μ : YoungDiagram) : 0 < nDim (jtSimple μ) := by - haveI := jtSimple_simple μ - haveI := IsSimpleModule.nontrivial + have := jtSimple_simple μ + have := IsSimpleModule.nontrivial (MonoidAlgebra ℂ (Equiv.Perm (Fin μ.card))) (jtSimple μ) - haveI : Nontrivial (subCarrier (jtSimple μ)) := + have : Nontrivial (subCarrier (jtSimple μ)) := inferInstanceAs (Nontrivial (jtSimple μ)) exact Module.finrank_pos diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTower.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTower.lean index 5aa05ce550..e301b99d55 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTower.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTower.lean @@ -85,7 +85,7 @@ noncomputable def permToEnd (n : ℕ) : Equiv.Perm (Fin n) →* skeinEnd f n where toFun σ := permClass f n σ map_one' := by - show HomSpace.ofFragment f.val (permFragment 1) = + change HomSpace.ofFragment f.val (permFragment 1) = HomSpace.ofFragment f.val (strandBundle n) rw [permFragment_one] map_mul' σ τ := by @@ -146,7 +146,7 @@ theorem homSpace_finrank_le (t : ℕ) : 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 - show Module.finrank ℂ (HomSpace f.val (n + n)) ≤ R ^ (2 * n) + 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) @@ -255,7 +255,7 @@ theorem skeinRep_compat {m n : ℕ} (h : m ≤ n) (x : SymGroupAlgebra m) have hsym : symCast h (MonoidAlgebra.of ℂ _ σ) = MonoidAlgebra.of ℂ _ (Equiv.Perm.viaEmbeddingHom (Fin.castLEEmb h) σ) := by - show MonoidAlgebra.mapDomain _ (MonoidAlgebra.single σ 1) = + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single σ 1) = MonoidAlgebra.single _ 1 exact MonoidAlgebra.mapDomain_single conv_lhs => rw [hsym, skeinRep_of] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTrace.lean index 5e6790565d..55fa0222c9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTrace.lean @@ -37,14 +37,14 @@ theorem skeinTrace_tensorHom {a b : ℕ} MonoidalCategoryStruct.tensorHom u v) = skeinTrace f a u * skeinTrace f b v := by -- Reduce to HomSpace operations - show HomSpace.traceMap f.val (a + b) + 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 - show traceFunctional f.val (a + b) (tensorFinsupp a a b b xu xv) = + 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 : ℂ), diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SuperKill.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SuperKill.lean index 97da532975..3da4ed05a6 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SuperKill.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SuperKill.lean @@ -27,8 +27,8 @@ 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 - letI := P.additive - letI := P.linear + let := P.additive + let := P.linear rw [superPermAction_eq_zero_iff, omegaSkeinRep_eq, hx] exact P.ω.map_zero _ _ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPerm.lean index e5270e8bad..ae252131d3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPerm.lean @@ -302,7 +302,7 @@ theorem insertTop_braid_le 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 - show swapTop X (n' + 1) ≫ (insertTop X (n' + 1) (a' + 1) ▷ X) ≫ + 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)) @@ -585,7 +585,7 @@ theorem permMor_mul [Category.{v} A] [MonoidalCategory A] [SymmetricCategory A] induction n with | zero => intro σ τ - show 𝟙 _ = 𝟙 _ ≫ 𝟙 _ + change 𝟙 _ = 𝟙 _ ≫ 𝟙 _ exact (Category.comp_id _).symm | succ n' ih => match n' with diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPermCast.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPermCast.lean index 6a71d655e0..9306d9b0ea 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPermCast.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPermCast.lean @@ -48,7 +48,7 @@ noncomputable def whiskerAlg map_zero' := MonoidalPreadditive.zero_whiskerRight map_add' f g := MonoidalPreadditive.add_whiskerRight f g commutes' c := by - show (c • 𝟙 P) ▷ X = c • 𝟙 (P ⊗ X) + change (c • 𝟙 P) ▷ X = c • 𝟙 (P ⊗ X) rw [MonoidalLinear.smul_whiskerRight, MonoidalCategory.id_whiskerRight] @@ -115,14 +115,14 @@ theorem permAlg_symCast (whiskerPowAlg X m k).comp (permAlg X m) := by refine MonoidAlgebra.algHom_ext (R := ℂ) (A := ℂ) (M := Equiv.Perm (Fin m)) (fun σ => ?_) (by ext) - show permAlg X (m + k) (symCast _ (MonoidAlgebra.single σ 1)) = + 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 - show MonoidAlgebra.mapDomain _ (MonoidAlgebra.single σ 1) = + change MonoidAlgebra.mapDomain _ (MonoidAlgebra.single σ 1) = MonoidAlgebra.single _ 1 exact MonoidAlgebra.mapDomain_single rw [hsym, permAlg_single, permAlg_single] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowSplit.lean index a82635e924..60d99a2380 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowSplit.lean @@ -163,7 +163,7 @@ 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 - show ((f ▷ X) ▷ X) ≫ + 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) @@ -180,11 +180,11 @@ private theorem swapBase_tensor [Category.{v} A] [MonoidalCategory A] (α_ P (Q ⊗ X) X).hom = ((α_ P Q X).hom ▷ X) ≫ (α_ P (Q ⊗ X) X).hom ≫ (P ◁ swapBase Q X) := by - show swapBase (P ⊗ Q) X ≫ ((α_ P Q X).hom ▷ X) ≫ + 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)) - show ((α_ (P ⊗ Q) X X).hom ≫ ((P ⊗ Q) ◁ (β_ X X).hom) ≫ + 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] @@ -199,7 +199,7 @@ theorem swapTop_comp_splitPow [Category.{v} A] [MonoidalCategory A] (splitPow X p (q + 1 + 1)).hom ≫ (tensorPow A X p ◁ swapTop X q) := by rw [splitPow_succ, splitPow_succ] - show swapBase (tensorPow A X (p + q)) X ≫ + 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 = @@ -229,7 +229,7 @@ private theorem whiskerRight_comp_splitPow [Category.{v} A] [MonoidalCategory A] (splitPow X p (q + 1)).hom ≫ (tensorPow A X p ◁ (v ▷ X)) := by rw [splitPow_succ] - show (u ▷ X) ≫ (((splitPow X p q).hom ▷ X) ≫ + 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)) ≫ @@ -288,7 +288,7 @@ private theorem tensorHom_comp_splitPow [Category.{v} A] [MonoidalCategory A] (u ⊗ₘ c) ≫ (splitPow X p (q + 1)).hom = (splitPow X p (q + 1)).hom ≫ (a ⊗ₘ (b ⊗ₘ c)) := by rw [splitPow_succ] - show (u ⊗ₘ c) ≫ (((splitPow X p q).hom ▷ X) ≫ + 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)) ≫ @@ -328,7 +328,7 @@ theorem powHom_comp_splitPow [Category.{v} A] [MonoidalCategory A] (splitPow X p q).hom ≫ (powHom X g p ⊗ₘ powHom X g q) | 0 => by rw [splitPow_zero] - show powHom X g p ≫ (ρ_ (tensorPow A X p)).inv = + 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 @@ -349,7 +349,7 @@ theorem permMor_comp_splitPow [Category.{v} A] [MonoidalCategory A] (splitPow X p q).hom ≫ (permMor X p σ ⊗ₘ permMor X q τ) | 0, τ => by rw [blockSum_of_zero, splitPow_zero] - show permMor X p σ ≫ (ρ_ (tensorPow A X p)).inv = + 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 @@ -367,7 +367,7 @@ theorem permMor_comp_splitPow [Category.{v} A] [MonoidalCategory A] (blockSum (p := p) (q := q + 1) σ τ) = (permMor X (p + q) (blockSum σ (restPerm τ)) ▷ X) ≫ insertTop X (p + q) (q - (topImage τ : ℕ)) := by - show permMor X (p + q + 1) + change permMor X (p + q + 1) (blockSum (p := p) (q := q + 1) σ τ) = _ rw [permMor_succ X (p + q) (blockSum (p := p) (q := q + 1) σ τ), diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/CircleValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CircleValue.lean index cf029e2e41..a13826a03e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/CircleValue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CircleValue.lean @@ -26,7 +26,7 @@ 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 - show (LinearMap.coprod (TensorProduct.lift (stdFormEvenBilin k)) + change (LinearMap.coprod (TensorProduct.lift (stdFormEvenBilin k)) (TensorProduct.lift (stdFormOddBilin ℓ))) ((LinearMap.toSpanSingleton ℂ _ (stdCopairEvenElem k, stdCopairOddElem ℓ)) 1) = diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/Coordinates.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/Coordinates.lean index c6423b13e9..4b211f54c9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/Coordinates.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/Coordinates.lean @@ -141,36 +141,36 @@ theorem symplecticMatrix_eq_std (ℓ : ℕ) (i j : Fin (2 * ℓ)) : ((i : ℕ) + ℓ = (j : ℕ) ∨ (j : ℕ) + ℓ = (i : ℕ)) := by unfold oddPartner rcases Nat.lt_or_ge i.val ℓ with h | h - · rw [dif_pos h] + · rw [dite_eq_left h] constructor · intro hh have h2 : (j : ℕ) = i.val + ℓ := congrArg Fin.val hh omega · intro hh refine Fin.ext ?_ - show (j : ℕ) = i.val + ℓ + change (j : ℕ) = i.val + ℓ omega - · rw [dif_neg (Nat.not_lt.mpr h)] + · 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 ?_ - show (j : ℕ) = i.val - ℓ + change (j : ℕ) = i.val - ℓ omega by_cases hp : j = oddPartner ℓ i - · rw [if_pos hp] + · rw [ite_eq_left hp] unfold oddPartnerSign rcases hpart.mp hp with h1 | h1 - · rw [if_pos h1, if_pos (show i.val < ℓ by omega)] + · rw [ite_eq_left h1, ite_eq_left (show i.val < ℓ by omega)] norm_num - · rw [if_neg (show ¬ (i : ℕ) + ℓ = (j : ℕ) by omega), if_pos h1, - if_neg (show ¬ i.val < ℓ by omega)] + · rw [ite_eq_right (show ¬ (i : ℕ) + ℓ = (j : ℕ) by omega), ite_eq_left h1, + ite_eq_right (show ¬ i.val < ℓ by omega)] norm_num - · rw [if_neg hp, - if_neg (fun hh => hp (hpart.mpr (Or.inl hh))), - if_neg (fun hh => hp (hpart.mpr (Or.inr hh)))] + · 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 -/ @@ -190,10 +190,10 @@ theorem exists_even_coordinates {V : Type} [AddCommGroup V] LinearMap.smul_apply, smul_eq_mul, hbb] unfold stdFormEven refine Finset.sum_congr rfl (fun i _ => ?_) - rw [Finset.sum_eq_single i, if_pos rfl, mul_one] + rw [Finset.sum_eq_single i, ite_eq_left rfl, mul_one] · exact mul_comm _ _ · intro m _ hm - rw [if_neg hm, mul_zero] + rw [ite_eq_right hm, mul_zero] · intro hmem exact absurd (Finset.mem_univ i) hmem @@ -219,10 +219,10 @@ theorem exists_odd_coordinates {V : Type} [AddCommGroup V] _ _ (fun i => ?_) simp only [Equiv.coe_fn_mk] rw [Finset.sum_eq_single (oddPartner ℓ i), - if_pos (oddPartner_invol ℓ i).symm, oddPartner_invol] + ite_eq_left (oddPartner_invol ℓ i).symm, oddPartner_invol] · ring · intro m _ hm - rw [if_neg (fun hh => hm (by rw [hh, oddPartner_invol])), mul_zero] + rw [ite_eq_right (fun hh => hm (by rw [hh, oddPartner_invol])), mul_zero] · intro hmem exact absurd (Finset.mem_univ (oddPartner ℓ i)) hmem diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/CopairUnique.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CopairUnique.lean index 58f675e979..14b2ffd823 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/CopairUnique.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CopairUnique.lean @@ -195,7 +195,7 @@ theorem contractionMap_stdCopairOddElem (ℓ : ℕ) /-- 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 - show LinearMap.coprod (TensorProduct.lift (stdFormEvenBilin k)) + 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, @@ -205,7 +205,7 @@ theorem formEvenBlock_stdForm (k ℓ : ℕ) (x y : Fin k → ℂ) : /-- 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 - show LinearMap.coprod (TensorProduct.lift (stdFormEvenBilin k)) + change LinearMap.coprod (TensorProduct.lift (stdFormEvenBilin k)) (TensorProduct.lift (stdFormOddBilin ℓ)) (0, x ⊗ₜ[ℂ] y) = stdFormOdd ℓ x y rw [LinearMap.coprod_apply, map_zero, zero_add, diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/SnakeTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/SnakeTransport.lean index fd9049c43c..707e25b380 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/SnakeTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/SnakeTransport.lean @@ -80,20 +80,20 @@ theorem exists_std_model {V : SuperVect} refine ⟨k, ℓ, e, e', hinv1, hinv2, hform, ?_⟩ let eIso : stdSuperPair k ℓ ≅ V := ⟨e, e', hinv1, hinv2⟩ - letI EPV : ExactPairing V V := exactPairingOfSnake b C h1 h2 - letI EP : ExactPairing (stdSuperPair k ℓ) (stdSuperPair k ℓ) := + 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 - show stdSuperPair k ℓ ◁ eIso.hom ≫ + 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 - show ((show 𝟙_ SuperVect ⟶ V ⊗ V from C) ≫ V ◁ eIso.inv) ≫ + change ((show 𝟙_ SuperVect ⟶ V ⊗ V from C) ≫ V ◁ eIso.inv) ≫ eIso.inv ▷ stdSuperPair k ℓ = _ rw [Category.assoc, ← tensorHom_def' eIso.inv eIso.inv] rfl diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdDuality.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdDuality.lean index 888ab06359..5e323573fe 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdDuality.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdDuality.lean @@ -30,25 +30,25 @@ noncomputable def stdFormEvenBilin (k : ℕ) : unfold stdFormEven rw [← Finset.sum_add_distrib] exact Finset.sum_congr rfl (fun i _ => by - show (x i + x' i) * y i = _ + 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 - show (c * x i) * y i = _ + 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 - show x i * (y i + y' i) = _ + 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 - show x i * (c * y i) = _ + change x i * (c * y i) = _ ring)) /-- The odd form as a bilinear map. -/ @@ -59,26 +59,26 @@ noncomputable def stdFormOddBilin (ℓ : ℕ) : unfold stdFormOdd rw [← Finset.sum_add_distrib] exact Finset.sum_congr rfl (fun i _ => by - show -(oddPartnerSign ℓ i : ℂ) * (x i + x' i) * y (oddPartner ℓ i) = _ + 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 - show -(oddPartnerSign ℓ i : ℂ) * (c * x i) * y (oddPartner ℓ i) = _ + 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 - show -(oddPartnerSign ℓ i : ℂ) * x i * + 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 - show -(oddPartnerSign ℓ i : ℂ) * x i * + change -(oddPartnerSign ℓ i : ℂ) * x i * (c * y (oddPartner ℓ i)) = _ ring)) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean index 8f114599a5..11bfe83b11 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean @@ -95,7 +95,7 @@ private theorem std_coev_ev (k ℓ : ℕ) : (TensorProduct.lid ℂ (Fin k → ℂ)).symm.toLinearMap) ∘ₗ ((TensorProduct.rid ℂ (Fin k → ℂ)).toLinearMap ∘ₗ LinearMap.fst ℂ _ _) ext x - all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, + all_goals simp? [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, stdCopairOddElem, mk_sum_split, mk_sum_left, mk_add_left, mk_smul_left, mk_smul_right, @@ -112,7 +112,7 @@ private theorem std_coev_ev (k ℓ : ℕ) : (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, if_pos] + Finset.mem_univ, ite_eq_left] · change (LinearMap.prodMap (TensorProduct.map @@ -133,7 +133,7 @@ private theorem std_coev_ev (k ℓ : ℕ) : ((TensorProduct.rid ℂ (Fin (2 * ℓ) → ℂ)).toLinearMap ∘ₗ LinearMap.snd ℂ _ _) ext x - all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, + all_goals simp? [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, stdCopairOddElem, mk_sum_split, mk_sum_left, mk_sum_right, mk_add_right, mk_smul_left, mk_smul_right, @@ -154,14 +154,14 @@ private theorem std_coev_ev (k ℓ : ℕ) : exact Finset.sum_congr rfl (fun n _ => by ring) simp only [hinner, stdFormOdd_stdF] rw [Finset.sum_eq_single (oddPartner ℓ x)] - · rw [if_pos rfl, oddPartner_invol, oddPartnerSign_oddPartner, + · 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 [if_neg (fun hh : m = oddPartner ℓ x => hm hh), + rw [ite_eq_right (fun hh : m = oddPartner ℓ x => hm hh), TensorProduct.zero_tmul, smul_zero] · intro hmem exact absurd (Finset.mem_univ _) hmem @@ -199,7 +199,7 @@ private theorem std_ev_coev (k ℓ : ℕ) : (TensorProduct.rid ℂ (Fin k → ℂ)).symm.toLinearMap) ∘ₗ ((TensorProduct.lid ℂ (Fin k → ℂ)).toLinearMap ∘ₗ LinearMap.fst ℂ _ _) ext x - all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, + all_goals simp? [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, stdCopairOddElem, mk_sum_split, mk_sum_left, mk_add_left, mk_smul_left, mk_smul_right, @@ -216,7 +216,7 @@ private theorem std_ev_coev (k ℓ : ℕ) : (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, if_pos] + Finset.mem_univ, ite_eq_left] · change (LinearMap.prodMap (TensorProduct.map LinearMap.id (0 : _ →ₗ[ℂ] PUnit)) @@ -237,7 +237,7 @@ private theorem std_ev_coev (k ℓ : ℕ) : ((TensorProduct.lid ℂ (Fin (2 * ℓ) → ℂ)).toLinearMap ∘ₗ LinearMap.fst ℂ _ _) ext x - all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, + all_goals simp? [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, stdCopairOddElem, mk_sum_split, mk_sum_left, mk_sum_right, mk_add_left, mk_smul_left, mk_smul_right, @@ -259,13 +259,13 @@ private theorem std_ev_coev (k ℓ : ℕ) : simp only [hinner, stdFormOdd_stdF, oddPartner_invol, oddPartnerSign_oddPartner, Int.cast_neg, neg_neg] rw [Finset.sum_eq_single x] - · rw [if_pos rfl, ← TensorProduct.tmul_smul, smul_eq_mul, + · 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 [if_neg (fun hh : x = m => hm hh.symm), + rw [ite_eq_right (fun hh : x = m => hm hh.symm), TensorProduct.tmul_zero, smul_zero] · intro hmem exact absurd (Finset.mem_univ _) hmem diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdSuper.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdSuper.lean index c102dffe25..2eef208db5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdSuper.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdSuper.lean @@ -64,7 +64,7 @@ theorem stdFormEven_stdE (k : ℕ) (i j : Fin k) : 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, if_neg h] + · 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 @@ -79,8 +79,8 @@ theorem stdFormOdd_stdF (ℓ : ℕ) (i j : Fin (2 * ℓ)) : 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, if_pos rfl, mul_one] - · rw [Pi.single_eq_of_ne (fun hh => h hh.symm), if_neg h, + · 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] @@ -95,7 +95,7 @@ theorem stdFormOdd_antisymm (ℓ : ℕ) (x y : Fin (2 * ℓ) → ℂ) : refine Fintype.sum_equiv ⟨oddPartner ℓ, oddPartner ℓ, oddPartner_invol ℓ, oddPartner_invol ℓ⟩ _ _ (fun i => ?_) - show -(oddPartnerSign ℓ i : ℂ) * x i * y (oddPartner ℓ i) = + change -(oddPartnerSign ℓ i : ℂ) * x i * y (oddPartner ℓ i) = -(-(oddPartnerSign ℓ (oddPartner ℓ i) : ℂ) * y (oddPartner ℓ i) * x (oddPartner ℓ (oddPartner ℓ i))) rw [oddPartner_invol, oddPartnerSign_oddPartner] @@ -121,19 +121,19 @@ theorem stdFormOdd_stdF_stdG (ℓ : ℕ) (i j : Fin (2 * ℓ)) : stdFormOdd_stdF] by_cases h : i = j · subst h - rw [if_pos rfl, if_pos rfl, mul_neg, ← Int.cast_mul, + rw [ite_eq_left rfl, ite_eq_left rfl, mul_neg, ← Int.cast_mul, oddPartnerSign_mul_self, Int.cast_one] - · rw [if_neg (fun hh : oddPartner ℓ j = oddPartner ℓ i => + · 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, if_neg h] + 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 (if_pos 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ℓ`; @@ -142,7 +142,7 @@ 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 (if_pos rfl))] + (fun i _ => (stdFormOdd_stdF_stdG ℓ i i).trans (ite_eq_left rfl))] simp /-- The even form against a basis vector reads off the diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalAgreement.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalAgreement.lean index ec8a1f0b74..f2dcfb5f5c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalAgreement.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalAgreement.lean @@ -36,7 +36,7 @@ existing even colouring — so no `(k, ℓ) = (0, 0)` edge case arises. namespace RS -open scoped Classical + variable {α : Type} {W : Fragment α} @@ -272,8 +272,8 @@ theorem throughSummand_evenState [LinearOrder α] refine Finset.sum_congr rfl fun ψ _ => ?_ by_cases hm : genEvenBoundaryMatch F (evenState hall ℓ ψ₀) (evenState_matches hall ℓ ψ₀) ψ - · rw [if_pos hm, - if_pos ((genEvenBoundaryMatch_evenState_iff hall ψ₀ ψ).mp hm)] + · 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 @@ -288,11 +288,11 @@ theorem throughSummand_evenState [LinearOrder α] h.evalOdd (F.evenColoursAt ψ v) (F.oddListAt o φ v))) (fun φ_core => ?_) - rw [if_pos (coreOddBoundaryMatch_evenState hall ψ₀ φ_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 [if_neg hm, if_neg (fun he => hm + · rw [ite_eq_right hm, ite_eq_right (fun he => hm ((genEvenBoundaryMatch_evenState_iff hall ψ₀ ψ).mpr he))] /-! ## The fibre decomposition of the mixed summand -/ @@ -337,7 +337,7 @@ edge subset does not depend on the choice of transition system and orientation. -/ theorem eulerianIndependence : EulerianIndependence := by intro α W F k ℓ h κ κ' o o' - letI : LinearOrder α := IsWellOrder.linearOrder WellOrderingRel + 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'] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalIndependence.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalIndependence.lean index 68e6b87711..8972c9fb73 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalIndependence.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalIndependence.lean @@ -18,7 +18,7 @@ Proposition 3 for the boundary-free sector, as a theorem. namespace RS -open scoped Classical + variable {α : Type} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedInstance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedInstance.lean index 0de374d4ad..3afb9fe159 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedInstance.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedInstance.lean @@ -142,19 +142,19 @@ theorem hexagonF_label (a b c : ℕ) : 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 - show b + x.val = b + x.val + change b + x.val = b + x.val rfl), tensorMapEquiv_natAdd, transposeEquiv_low a c x.val h1 (by omega) (by omega)] exact (by - show (b + c) + x.val = b + (c + x.val) + 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 - show x.val = a + (x.val - a) + change x.val = a + (x.val - a) omega), transposeEquiv_high a (b + c) (x.val - a) (by omega) (by omega) (by omega)] @@ -162,7 +162,7 @@ theorem hexagonF_label (a b c : ℕ) : _root_.Equiv.trans_apply, show x = Fin.castAdd c (Fin.natAdd a ⟨x.val - a, by omega⟩) from Fin.ext (by - show x.val = a + (x.val - a) + change x.val = a + (x.val - a) omega), tensorMapEquiv_castAdd, show (transposeEquiv a b) (Fin.natAdd a @@ -183,7 +183,7 @@ theorem hexagonF_label (a b c : ℕ) : _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 - show x.val = a + (x.val - a) + change x.val = a + (x.val - a) omega), transposeEquiv_high a (b + c) (x.val - a) (by omega) (by omega) (by omega)] @@ -191,7 +191,7 @@ theorem hexagonF_label (a b c : ℕ) : _root_.Equiv.trans_apply, show x = Fin.natAdd (a + b) ⟨x.val - (a + b), by omega⟩ from Fin.ext (by - show x.val = (a + b) + (x.val - (a + b)) + change x.val = (a + b) + (x.val - (a + b)) omega), tensorMapEquiv_natAdd, show ((_root_.Equiv.refl (Fin c)) @@ -201,7 +201,7 @@ theorem hexagonF_label (a b 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 - show (b + a) + (x.val - (a + b)) = + change (b + a) + (x.val - (a + b)) = b + (a + (x.val - (a + b))) omega), tensorMapEquiv_natAdd, @@ -211,7 +211,7 @@ theorem hexagonF_label (a b c : ℕ) : transposeEquiv_high a c (x.val - (a + b)) (by omega) (by omega) (by omega)] exact (by - show x.val - a = b + (x.val - (a + b)) + change x.val - a = b + (x.val - (a + b)) omega) /-- The reverse hexagon label identity. -/ @@ -262,7 +262,7 @@ theorem hexagonR_label (a b c : ℕ) : _root_.Equiv.trans_apply, show x = Fin.natAdd a ⟨x.val - a, by omega⟩ from Fin.ext (by - show x.val = a + (x.val - a) + change x.val = a + (x.val - a) omega), tensorMapEquiv_natAdd, show (transposeEquiv b c) ⟨x.val - a, by omega⟩ = @@ -273,18 +273,18 @@ theorem hexagonR_label (a b c : ℕ) : (Fin.natAdd a ⟨c + (x.val - a), by omega⟩) = Fin.natAdd (a + c) ⟨x.val - a, by omega⟩ from Fin.ext (by - show a + (c + (x.val - a)) = (a + c) + (x.val - a) + change a + (c + (x.val - a)) = (a + c) + (x.val - a) omega), tensorMapEquiv_natAdd] exact (by - show c + x.val = (c + a) + (x.val - a) + 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 - show x.val = (a + b) + (x.val - (a + b)) + 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)] @@ -292,14 +292,14 @@ theorem hexagonR_label (a b c : ℕ) : _root_.Equiv.trans_apply, show x = Fin.natAdd a ⟨x.val - a, by omega⟩ from Fin.ext (by - show x.val = a + (x.val - a) + 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 - show x.val - a = b + (x.val - a - b) + 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), @@ -317,7 +317,7 @@ theorem hexagonR_label (a b c : ℕ) : exact transposeEquiv_high a c (x.val - a - b) (by omega) (by omega) (by omega)] exact (by - show x.val - (a + b) = x.val - a - b + change x.val - (a + b) = x.val - a - b omega) /-- **The braided skein category.** -/ @@ -329,7 +329,7 @@ noncomputable instance skeinBraided : braiding_naturality_left {X Y} p Z := braidNatLeft_class f Z.arity p hexagon_forward X Y Z := by - show HomSpace.comp f _ _ _ + change HomSpace.comp f _ _ _ (bundleMapClass f (finCongr _)) (HomSpace.comp f _ _ _ (bundleMapClass f (transposeEquiv X.arity @@ -352,7 +352,7 @@ noncomputable instance skeinBraided : exact bundleMapClass_congr f (hexagonF_label X.arity Y.arity Z.arity) hexagon_reverse X Y Z := by - show HomSpace.comp f _ _ _ + change HomSpace.comp f _ _ _ (bundleMapClass f (finCongr _)) (HomSpace.comp f _ _ _ (bundleMapClass f (transposeEquiv diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedNat.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedNat.lean index 2b35d01164..c7839f4e4f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedNat.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedNat.lean @@ -89,7 +89,7 @@ theorem braidNatLeft_label (s t k : ℕ) : _root_.Equiv.trans_apply, finSumFinEquiv_symm_apply_castAdd, _root_.Equiv.trans_apply] - show (finSumFinEquiv (Sum.inl (Fin.natAdd s + 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 @@ -102,7 +102,7 @@ theorem braidNatLeft_label (s t k : ℕ) : · 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 - show x.val = k + (x.val - k) + change x.val = k + (x.val - k) omega), _root_.Equiv.trans_apply, tensorSwapEquiv_in_right s t k k ⟨x.val - k, by omega⟩, @@ -111,12 +111,12 @@ theorem braidNatLeft_label (s t k : ℕ) : _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 - show x.val = k + (x.val - k) + change x.val = k + (x.val - k) omega), _root_.Equiv.trans_apply, finSumFinEquiv_symm_apply_castAdd, _root_.Equiv.trans_apply] - show (finSumFinEquiv (Sum.inl (Fin.castAdd k + 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 @@ -132,7 +132,7 @@ theorem braidNatLeft_label (s t k : ℕ) : · conv_lhs => rw [show x = Fin.natAdd (k + s) (Fin.castAdd t ⟨x.val - (k + s), by omega⟩) from Fin.ext (by - show x.val = (k + s) + (x.val - (k + s)) + change x.val = (k + s) + (x.val - (k + s)) omega), _root_.Equiv.trans_apply, tensorSwapEquiv_out_left s t k k @@ -143,12 +143,12 @@ theorem braidNatLeft_label (s t k : ℕ) : conv_rhs => rw [show x = Fin.natAdd (k + s) (Fin.castAdd t ⟨x.val - (k + s), by omega⟩) from Fin.ext (by - show x.val = (k + s) + (x.val - (k + s)) + change x.val = (k + s) + (x.val - (k + s)) omega), _root_.Equiv.trans_apply, finSumFinEquiv_symm_apply_natAdd, _root_.Equiv.trans_apply] - show (finSumFinEquiv (Sum.inr ((transposeEquiv t k) + 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 @@ -163,7 +163,7 @@ theorem braidNatLeft_label (s t k : ℕ) : · conv_lhs => rw [show x = Fin.natAdd (k + s) (Fin.natAdd k ⟨x.val - ((k + s) + k), by omega⟩) from Fin.ext (by - show x.val = (k + s) + (k + (x.val - ((k + s) + k))) + change x.val = (k + s) + (k + (x.val - ((k + s) + k))) omega), _root_.Equiv.trans_apply, tensorSwapEquiv_out_right s t k k @@ -174,12 +174,12 @@ theorem braidNatLeft_label (s t k : ℕ) : conv_rhs => rw [show x = Fin.natAdd (k + s) (Fin.natAdd k ⟨x.val - ((k + s) + k), by omega⟩) from Fin.ext (by - show x.val = (k + s) + (k + (x.val - ((k + s) + k))) + change x.val = (k + s) + (k + (x.val - ((k + s) + k))) omega), _root_.Equiv.trans_apply, finSumFinEquiv_symm_apply_natAdd, _root_.Equiv.trans_apply] - show (finSumFinEquiv (Sum.inr ((transposeEquiv t k) + change (finSumFinEquiv (Sum.inr ((transposeEquiv t k) (Fin.castAdd k ⟨x.val - ((k + s) + k), by omega⟩)))).val = (finSumFinEquiv (Sum.inr (Fin.natAdd k @@ -237,7 +237,7 @@ theorem braidNatRight_label (s t k : ℕ) : _root_.Equiv.trans_apply, finSumFinEquiv_symm_apply_castAdd, _root_.Equiv.trans_apply] - show (finSumFinEquiv (Sum.inl (Fin.natAdd k + 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 @@ -250,7 +250,7 @@ theorem braidNatRight_label (s t k : ℕ) : · 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 - show x.val = s + (x.val - s) + change x.val = s + (x.val - s) omega), _root_.Equiv.trans_apply, tensorSwapEquiv_in_right k k s t ⟨x.val - s, by omega⟩, @@ -259,12 +259,12 @@ theorem braidNatRight_label (s t k : ℕ) : _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 - show x.val = s + (x.val - s) + change x.val = s + (x.val - s) omega), _root_.Equiv.trans_apply, finSumFinEquiv_symm_apply_castAdd, _root_.Equiv.trans_apply] - show (finSumFinEquiv (Sum.inl (Fin.castAdd s + 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 @@ -280,7 +280,7 @@ theorem braidNatRight_label (s t k : ℕ) : · conv_lhs => rw [show x = Fin.natAdd (s + k) (Fin.castAdd k ⟨x.val - (s + k), by omega⟩) from Fin.ext (by - show x.val = (s + k) + (x.val - (s + k)) + change x.val = (s + k) + (x.val - (s + k)) omega), _root_.Equiv.trans_apply, tensorSwapEquiv_out_left k k s t @@ -291,12 +291,12 @@ theorem braidNatRight_label (s t k : ℕ) : conv_rhs => rw [show x = Fin.natAdd (s + k) (Fin.castAdd k ⟨x.val - (s + k), by omega⟩) from Fin.ext (by - show x.val = (s + k) + (x.val - (s + k)) + change x.val = (s + k) + (x.val - (s + k)) omega), _root_.Equiv.trans_apply, finSumFinEquiv_symm_apply_natAdd, _root_.Equiv.trans_apply] - show (finSumFinEquiv (Sum.inr ((transposeEquiv k t) + 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 @@ -311,7 +311,7 @@ theorem braidNatRight_label (s t k : ℕ) : · conv_lhs => rw [show x = Fin.natAdd (s + k) (Fin.natAdd t ⟨x.val - ((s + k) + t), by omega⟩) from Fin.ext (by - show x.val = (s + k) + (t + (x.val - ((s + k) + t))) + change x.val = (s + k) + (t + (x.val - ((s + k) + t))) omega), _root_.Equiv.trans_apply, tensorSwapEquiv_out_right k k s t @@ -322,12 +322,12 @@ theorem braidNatRight_label (s t k : ℕ) : conv_rhs => rw [show x = Fin.natAdd (s + k) (Fin.natAdd t ⟨x.val - ((s + k) + t), by omega⟩) from Fin.ext (by - show x.val = (s + k) + (t + (x.val - ((s + k) + t))) + change x.val = (s + k) + (t + (x.val - ((s + k) + t))) omega), _root_.Equiv.trans_apply, finSumFinEquiv_symm_apply_natAdd, _root_.Equiv.trans_apply] - show (finSumFinEquiv (Sum.inr ((transposeEquiv k t) + change (finSumFinEquiv (Sum.inr ((transposeEquiv k t) (Fin.castAdd t ⟨x.val - ((s + k) + t), by omega⟩)))).val = (finSumFinEquiv (Sum.inr (Fin.natAdd t diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleClose.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleClose.lean index 26fd7cb943..052e6355dc 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleClose.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleClose.lean @@ -48,11 +48,11 @@ theorem mem_highCross_flat · rintro (⟨a, rfl, ha⟩ | ⟨b, rfl, hb⟩) · refine ⟨⟨a.val - m, by have := a.isLt; omega⟩, Or.inl ?_⟩ refine congrArg Sum.inl (Fin.ext ?_) - show a.val = m + (a.val - m) + 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 ?_) - show b.val = m + (b.val - m) + change b.val = m + (b.val - m) omega /-- The high block is a well-formed gluing list. -/ @@ -121,15 +121,15 @@ noncomputable def bcPhi : Fin (m + m) ≃ left_inv x := by by_cases h : x.val < m · have h1 : bcPhiFun m x = ⟨Sum.inl ⟨x.val, by omega⟩, _⟩ := - dif_pos h + dite_eq_left h rw [h1] - show (⟨x.val, _⟩ : Fin (m + m)) = x + 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⟩, _⟩ := - dif_neg h + dite_eq_right h rw [h1] - show (⟨m + (x.val - m), _⟩ : Fin (m + m)) = x + 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 @@ -139,22 +139,22 @@ noncomputable def bcPhi : Fin (m + m) ≃ by_contra hge exact hnot ((mem_highCross_flat m _).mpr (Or.inl ⟨a, rfl, by omega⟩)) - show bcPhiFun m ⟨a.val, by omega⟩ = _ + change bcPhiFun m ⟨a.val, by omega⟩ = _ have h1 : bcPhiFun m ⟨a.val, by omega⟩ = - ⟨Sum.inl ⟨a.val, by omega⟩, _⟩ := dif_pos ha + ⟨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⟩)) - show bcPhiFun m ⟨m + b.val, 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⟩, _⟩ := - dif_neg (show ¬ 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 - show m + b.val - m = b.val + change m + b.val - m = b.val omega))) /-! ### The ambient relabelling -/ @@ -291,15 +291,15 @@ theorem bcPhi_eq : have hy : (((interfaceSurvEquiv m m m).trans finSumFinEquiv).symm x) = ⟨Sum.inl ⟨x.val, by omega⟩, wpf⟩ := by - show (interfaceSurvEquiv m m m).symm + 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 (dif_pos hx) - show bcDelta m ((((interfaceSurvEquiv m m m).trans + 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) @@ -309,7 +309,7 @@ theorem bcPhi_eq : 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 show x.val = m + (x.val - m); omega)] + 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⟩ : @@ -332,19 +332,19 @@ theorem bcPhi_eq : have hy : (((interfaceSurvEquiv m m m).trans finSumFinEquiv).symm x) = ⟨Sum.inr ⟨x.val, x.isLt⟩, wpf⟩ := by - show (interfaceSurvEquiv m m m).symm + 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 (dif_neg hx) - show bcDelta m ((((interfaceSurvEquiv m m m).trans + 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 ?_) - show ((transposeEquiv m m).symm.trans + 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, @@ -352,7 +352,7 @@ theorem bcPhi_eq : 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 show x.val = m + (x.val - m); omega), + 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)] @@ -489,7 +489,7 @@ theorem mapPairs_bcPhi_lift : (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 - show m - 1 - j < m + change m - 1 - j < m omega) rw [hs1, hs2] exact Prod.ext (Fin.ext rfl) (Fin.ext rfl) @@ -518,7 +518,7 @@ noncomputable def pairCloseStrandBundle ((Fragment.glueList V (matchPairs m) (matchPairs_wf m)).relabel (_root_.Equiv.equivOfIsEmpty _ _)) := by - show ((V.relabel + change ((V.relabel (finCongr (by omega : m + m = 0 + (m + m)))).compose ((strandBundle m).relabel (finCongr (by omega : m + m = (m + m) + 0)))).Equiv _ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleMapClasses.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleMapClasses.lean index 9de6ae950f..4d3c25c76b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleMapClasses.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleMapClasses.lean @@ -47,7 +47,7 @@ noncomputable def bundleMapRefl (n : ℕ) : (strandBundle n) := (Fragment.Equiv.relabelEq (strandBundle n) (_root_.Equiv.ext (fun x => by - show finSumFinEquiv + change finSumFinEquiv ((_root_.Equiv.sumCongr (_root_.Equiv.refl (Fin n)) (_root_.Equiv.refl (Fin n))) (finSumFinEquiv.symm x)) = x @@ -94,7 +94,7 @@ noncomputable def tensorFragmentRelabel ((interleaveEquiv s t u v).symm.trans ((_root_.Equiv.sumCongr r₁ r₂).trans (interleaveEquiv s' t' u' v')))) := by - show (((X.relabel r₁).disjUnion (z.relabel r₂)).relabel + 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 @@ -102,7 +102,7 @@ noncomputable def tensorFragmentRelabel (Fragment.relabelDisjUnionRight X z r₂) _).trans (Fragment.Equiv.relabelTrans _ _ _))) _).trans ?_ refine (Fragment.Equiv.relabelTrans _ _ _).trans ?_ - show ((X.disjUnion z).relabel _).Equiv + change ((X.disjUnion z).relabel _).Equiv (((X.disjUnion z).relabel (interleaveEquiv s t u v)).relabel _) refine Fragment.Equiv.trans ?_ (Fragment.Equiv.relabelTrans _ _ _).symm @@ -177,7 +177,7 @@ noncomputable def bundleMapTensor {n₁ m₁ n₂ m₂ : ℕ} outMapEquiv_castAdd (tensorMapEquiv e₁ e₂)] · rw [show x = Fin.castAdd (n₁ + n₂) (Fin.natAdd n₁ ⟨x.val - n₁, by omega⟩) from - Fin.ext (by show x.val = n₁ + (x.val - n₁); omega), + 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⟩, @@ -190,7 +190,7 @@ noncomputable def bundleMapTensor {n₁ m₁ n₂ m₂ : ℕ} · rw [show x = Fin.natAdd (n₁ + n₂) (Fin.castAdd n₂ ⟨x.val - (n₁ + n₂), hx1⟩) from Fin.ext (by - show x.val = (n₁ + n₂) + (x.val - (n₁ + n₂)) + change x.val = (n₁ + n₂) + (x.val - (n₁ + n₂)) omega), _root_.Equiv.trans_apply, interleaveEquiv_symm_high_left n₁ n₁ n₂ n₂ @@ -206,7 +206,7 @@ noncomputable def bundleMapTensor {n₁ m₁ n₂ m₂ : ℕ} have := x.isLt omega⟩) from Fin.ext (by - show x.val = (n₁ + n₂) + (n₁ + (x.val - (n₁ + n₂) - n₁)) + change x.val = (n₁ + n₂) + (n₁ + (x.val - (n₁ + n₂) - n₁)) have := x.isLt omega), _root_.Equiv.trans_apply, @@ -277,7 +277,7 @@ theorem outTransport_finCongr {s n m : ℕ} (h : n = m) : · rw [show x = Fin.natAdd s ⟨x.val - s, by have := x.isLt omega⟩ from Fin.ext (by - show x.val = s + (x.val - s) + change x.val = s + (x.val - s) omega), _root_.Equiv.trans_apply, finSumFinEquiv_symm_apply_natAdd] @@ -300,7 +300,7 @@ theorem inTransport_finCongr {n m u : ℕ} (h : n = m) : · rw [show x = Fin.natAdd n ⟨x.val - n, by have := x.isLt omega⟩ from Fin.ext (by - show x.val = n + (x.val - n) + change x.val = n + (x.val - n) omega), _root_.Equiv.trans_apply, finSumFinEquiv_symm_apply_natAdd] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleTensor.lean index ed8f84e30e..a0207fd933 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleTensor.lean @@ -31,17 +31,17 @@ def bundleFlagEquiv (a b : ℕ) : | 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 [dif_pos h] - · simp only [dif_neg h] + · simp only [dite_eq_left h] + · simp only [dite_eq_right h] exact Prod.ext (Fin.ext (by - show a + (f.1.val - a) = f.1.val + change a + (f.1.val - a) = f.1.val omega)) rfl right_inv g := by rcases g with ⟨k, c⟩ | ⟨l, c⟩ - · simp only [dif_pos k.isLt] - · simp only [dif_neg (show ¬ a + l.val < a by omega)] + · 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) - show a + l.val - a = l.val + change a + l.val - a = l.val omega /-- **The bundle splits**: the `(a + b)`-strand bundle is the @@ -57,18 +57,18 @@ noncomputable def strandBundleTensor (a b : ℕ) : obtain ⟨k, c⟩ := f by_cases h : k.val < a · have hbfe : bundleFlagEquiv a b (k, c) = - Sum.inl (⟨k.val, h⟩, c) := dif_pos h - show (tensorFragment (strandBundle a) + 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 _ | _ - · show Sum.inr (interleaveEquiv a a b b + · 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) - · show Sum.inr (interleaveEquiv a a b b + · 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)) = @@ -77,12 +77,12 @@ noncomputable def strandBundleTensor (a b : ℕ) : 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) := - dif_neg h - show (tensorFragment (strandBundle a) + dite_eq_right h + change (tensorFragment (strandBundle a) (strandBundle b)).attach (bundleFlagEquiv a b (k, c)) = _ rw [hbfe] rcases c with _ | _ - · show Sum.inr (interleaveEquiv a a b b + · 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⟩ : @@ -90,9 +90,9 @@ noncomputable def strandBundleTensor (a 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 - show a + (k.val - a) = k.val + change a + (k.val - a) = k.val omega)) - · show Sum.inr (interleaveEquiv a a b b + · 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⟩ : @@ -100,30 +100,30 @@ noncomputable def strandBundleTensor (a 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 - show (a + b) + (a + (k.val - a)) = (a + b) + k.val + 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) := dif_pos h + Sum.inl (⟨k.val, h⟩, !c) := dite_eq_left h have h2 : bundleFlagEquiv a b (k, c) = - Sum.inl (⟨k.val, h⟩, c) := dif_pos h - show bundleFlagEquiv a b (k, !c) = _ + Sum.inl (⟨k.val, h⟩, c) := dite_eq_left h + change bundleFlagEquiv a b (k, !c) = _ rw [h1] - show _ = (tensorFragment (strandBundle a) + 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) := - dif_neg h + dite_eq_right h have h2 : bundleFlagEquiv a b (k, c) = Sum.inr (⟨k.val - a, by have := k.isLt; omega⟩, c) := - dif_neg h - show bundleFlagEquiv a b (k, !c) = _ + dite_eq_right h + change bundleFlagEquiv a b (k, !c) = _ rw [h1] - show _ = (tensorFragment (strandBundle a) + change _ = (tensorFragment (strandBundle a) (strandBundle b)).pairing (bundleFlagEquiv a b (k, c)) rw [h2] rfl diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonExistence.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonExistence.lean index 4f6a896116..1801501345 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonExistence.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonExistence.lean @@ -42,7 +42,7 @@ flags lying on non-canonically oriented boundary-to-boundary chains. namespace RS -open scoped Classical + variable {α : Type} @@ -111,7 +111,7 @@ theorem pathMatch_eq_of_chain {W : Fragment α} {F : EdgeSubset W} open EdgeSubset in /-- **A flag whose partner is a boundary flag is matched to it.** -/ -theorem pathMatch_eq_pairing_of_boundary {α : Type} [LinearOrder α] +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) : @@ -234,7 +234,7 @@ theorem canonIsOut_of_bad [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} {o : κ.Orientation} {f : W.Flag} (h : BadFlag κ o f) : canonIsOut κ o f = !o.isOut f := by unfold canonIsOut - rw [if_pos h] + rw [ite_eq_left h] /-- Elsewhere it leaves the orientation alone. -/ theorem canonIsOut_of_not_bad @@ -243,7 +243,7 @@ theorem canonIsOut_of_not_bad {o : κ.Orientation} {f : W.Flag} (h : ¬ BadFlag κ o f) : canonIsOut κ o f = o.isOut f := by unfold canonIsOut - rw [if_neg h] + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonTransport.lean index 80bc026f82..1798663b9d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonTransport.lean @@ -16,7 +16,7 @@ of a single-pair glue, and back up from a closed lift. namespace RS -open scoped Classical + /-! ## Transport along a relabel -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonicalFrame.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonicalFrame.lean index 76343ec573..a6712d0b8e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonicalFrame.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonicalFrame.lean @@ -28,7 +28,7 @@ over the anti-canonical chains re-canonicalizes any orientation namespace RS -open scoped Classical + namespace EdgeSubset @@ -91,7 +91,7 @@ theorem chainDir_pathMatch have hpm : κ.pathMatch β hβ = W.pairing (iterWalk κ β k) := κ.pathMatch_eq hβ (traceChain_fuel_mono κ (by omega) (traceChain_forward κ β hcont hterm)) - show o.isOut (W.pairing (κ.pathMatch β hβ)) = + 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 @@ -129,7 +129,7 @@ theorem pathCanonical_iff_chainDir exact W.eq_boundaryFlag _ _ (attach_boundaryLabel (κ.pathMatch_mem hβ)) have hval := hc _ _ hbB hintB hpm hlt - show o.isOut (W.pairing β) = false + change o.isOut (W.pairing β) = false rw [hβeq] exact hval · intro H i j hb hint hpm hij diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChainAgreement.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChainAgreement.lean index 80ee879be1..dd8e6a8c56 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChainAgreement.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChainAgreement.lean @@ -47,7 +47,7 @@ whole chain's values are determined by the pinned seed. namespace RS -open scoped Classical + variable {α : Type} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordCount.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordCount.lean index 8279d7a776..1a3352fba8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordCount.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordCount.lean @@ -21,7 +21,7 @@ the diagram, and they agree. namespace RS -open Classical + namespace EdgeSubset @@ -71,7 +71,7 @@ theorem boundaryFlag_chordInv {W : Fragment α} (h : W.boundaryFlag i ∈ F.boundaryFlags) : W.boundaryFlag (chordInv F κ i) = κ.pathMatch (W.boundaryFlag i) h := by unfold chordInv - rw [dif_pos h] + 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 @@ -95,7 +95,7 @@ theorem chordInv_invol {W : Fragment α} (κ.pathMatch_mem h)] exact κ.pathMatch_invol h · unfold chordInv - rw [dif_neg h, dif_neg h] + 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 α} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordLabels.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordLabels.lean index b9f4b6a3a9..788ca03d7d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordLabels.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordLabels.lean @@ -18,7 +18,7 @@ parity layer. namespace RS -open scoped Classical + variable {α : Type} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordParity.lean index 388eef4419..c17e288e4d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordParity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordParity.lean @@ -19,7 +19,7 @@ exactly one. namespace RS -open scoped Classical + variable {α : Type} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordSwapParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordSwapParity.lean index 5e7810f985..74f1b9c47a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordSwapParity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordSwapParity.lean @@ -27,7 +27,7 @@ coexisting crossing predicates: namespace RS -open scoped Classical + variable {α : Type} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotate.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotate.lean index eb255c735a..fe8893cfc3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotate.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotate.lean @@ -43,7 +43,7 @@ theorem transposeEquiv_low (n p : ℕ) (j : ℕ) (hj : j < n) Fin.ext rfl rw [_root_.Equiv.trans_apply, _root_.Equiv.trans_apply, h3, finSumFinEquiv_symm_apply_castAdd] - show finSumFinEquiv (Sum.inr ⟨j, hj⟩) = _ + change finSumFinEquiv (Sum.inr ⟨j, hj⟩) = _ rw [finSumFinEquiv_apply_right] exact Fin.ext rfl @@ -56,7 +56,7 @@ theorem transposeEquiv_high (n p : ℕ) (i : ℕ) (hi : i < p) Fin.ext rfl rw [_root_.Equiv.trans_apply, _root_.Equiv.trans_apply, h3, finSumFinEquiv_symm_apply_natAdd] - show finSumFinEquiv (Sum.inl ⟨i, hi⟩) = _ + change finSumFinEquiv (Sum.inl ⟨i, hi⟩) = _ rw [finSumFinEquiv_apply_left] exact Fin.ext rfl @@ -322,12 +322,12 @@ theorem interfacePairs_closure_split (m p : ℕ) : (List.map_congr_left fun ℓ _ => ?_) · refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) (congrArg Sum.inr (Fin.ext ?_)) - · show 0 + i.val = i.val + · change 0 + i.val = i.val omega · rfl · refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) (congrArg Sum.inr (Fin.ext ?_)) - · show 0 + (m + ℓ.val) = m + ℓ.val + · change 0 + (m + ℓ.val) = m + ℓ.val omega · rfl @@ -555,7 +555,7 @@ private theorem kh_pullback_aux (m n p : ℕ) : | ℓ :: 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) - show Sum.inr ((transposeEquiv n p).symm ⟨ℓ.val, _⟩) = _ + 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)) @@ -787,7 +787,7 @@ theorem rot_q4_eq (m n p : ℕ) : rotQ4 m n p = Fragment.liftPairs _ _ ((rotatePairsR_wf m n p).append_sep) := by - show Fragment.mapPairs (rotMR m n p).symm + change Fragment.mapPairs (rotMR m n p).symm (Fragment.mapPairs (Fragment.inrFoldEquiv (α := Fin (m + n)) (hkPairs m n p)).symm @@ -904,6 +904,10 @@ noncomputable def rotateLabelL (m n p : ℕ) : ((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. -/ @@ -924,7 +928,7 @@ noncomputable def rotateNormalLeft {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) := - Fragment.mapPairs_wf iL.symm _ wfqs1 + lhsQs2_wf m n p let A := (F.disjUnion H).disjUnion K let X := Fragment.glueList A (Fragment.inlPairs (interfacePairs m n p)) @@ -933,16 +937,7 @@ noncomputable def rotateNormalLeft {m n p : ℕ} (interfacePairs m n p) (interfacePairs_wf m n p) -- ═══════ STAGE 1: THE APPEND MERGE ═══════ -- C8: the append merge. - have C8 : (Fragment.glueList X (lhsQs2 m n p) wfqs2).Equiv - ((Fragment.glueList A - (Fragment.inlPairs (interfacePairs m n p) ++ - (pBlock m n p ++ mBlock m n p)) - (lhsCA_wf m n p)).relabel - ((Fragment.appendFlatten _ _ - ((lhsCA_wf m n p).append_sep)).symm.trans - (Fragment.foldSurvivingPermEquiv - ((lhs_pairs_lift m n p) ▸ - List.Perm.refl _)).symm)) := + have C8 := (Fragment.Equiv.relabelFlip' (Fragment.glueListEqEquiv X (lhs_pairs_lift m n p) wfqs2 @@ -980,7 +975,7 @@ noncomputable def rotateNormalLeft {m n p : ℕ} (Fragment.Equiv.relabelTrans _ _ _)) -- ═══════ STAGE 2: THE EMBEDDED FOLD ═══════ -- E4: the glued pair is the embedded fold. - have E4 : (N.disjUnion K).Equiv (X.relabel iL) := + have E4 := (Fragment.Equiv.relabelFlip (Fragment.glueListDisjUnionLeft (F.disjUnion H) K (interfacePairs m n p) @@ -1019,11 +1014,7 @@ noncomputable def rotateNormalLeft {m n p : ℕ} (Fragment.Equiv.relabelTrans _ _ _)) -- ═══════ STAGE 3: THE CLOSURE'S OWN INTERFACE ═══════ -- E1: peel the closure casts and normalize the composite. - have E1 : (((F.compose H).relabel - (finCongr (by omega : m + p = 0 + (m + p)))).disjUnion - (K.relabel - (finCongr (by omega : m + p = m + p + 0)))).Equiv - ((N.disjUnion K).relabel σL) := + 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 @@ -1109,6 +1100,11 @@ noncomputable def rotateLabelR (m n p : ℕ) : ((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. -/ @@ -1140,7 +1136,7 @@ noncomputable def rotateNormalRight {m n p : ℕ} let wfq3 : Fragment.PairsWF (rotQ3 m n p) := Fragment.mapPairs_wf i'.symm _ wfq2 let wfq4 : Fragment.PairsWF (rotQ4 m n p) := - Fragment.mapPairs_wf MR.symm _ wfq3 + 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) @@ -1160,14 +1156,7 @@ noncomputable def rotateNormalRight {m n p : ℕ} (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.glueList UPB (rotQ4 m n p) wfq4).Equiv - ((Fragment.glueList A - (pBlock m n p ++ (nBlock m n p ++ mBlock m n p)) - (rotatePairsR_wf m n p)).relabel - ((Fragment.appendFlatten _ _ - ((rotatePairsR_wf m n p).append_sep)).symm.trans - (Fragment.foldSurvivingPermEquiv - ((rot_q4_eq m n p) ▸ List.Perm.refl _)).symm)) := + have CRapp := (Fragment.Equiv.relabelFlip' (Fragment.glueListEqEquiv UPB (rot_q4_eq m n p) wfq4 @@ -1184,8 +1173,7 @@ noncomputable def rotateNormalRight {m n p : ℕ} ((rot_q4_eq m n p) ▸ List.Perm.refl _)).symm).trans (Fragment.Equiv.relabelTrans _ _ _)) -- CRX: the ambient bridge on the p-fold. - have BE : A.Equiv - ((F.disjUnion (K.disjUnion H)).relabel (rotBridge m n p)) := + have BE := (Fragment.disjUnionAssoc F H K).trans ((Fragment.Equiv.relabelCongr ((Fragment.Equiv.disjUnionCongr (Fragment.Equiv.refl F) @@ -1195,242 +1183,78 @@ noncomputable def rotateNormalRight {m n p : ℕ} (_root_.Equiv.sumAssoc (Fin (m + n)) (Fin (n + p)) (Fin (m + p))).symm).trans (Fragment.Equiv.relabelTrans _ _ _)) - have CRX : XR.Equiv (UPB.relabel MR) := - (Fragment.glueListCongr - (Fragment.Equiv.relabelFlip BE) _ _).trans - ((Fragment.Equiv.relabelFlip' - (Fragment.glueListEqEquiv - ((A.relabel (rotBridge m n p).symm)) - (mapPairs_symm_cancel (rotBridge m n p).symm - (Fragment.inrPairs (α := Fin (m + n)) - (hkPairs m n p))).symm - (Fragment.inrPairs_wf _ (hkPairs_wf m n p)) - (Fragment.mapPairs_wf (rotBridge m n p).symm _ wfground) - ((mapPairs_symm_cancel (rotBridge m n p).symm - (Fragment.inrPairs (α := Fin (m + n)) - (hkPairs m n p))).symm ▸ - List.Perm.refl _))).trans - ((Fragment.Equiv.relabelCongr - ((Fragment.glueListRelabel A (rotBridge m n p).symm - ground wfground).trans - ((Fragment.Equiv.relabelCongr - (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 _))) - (Fragment.foldSurvivingMapEquiv - (rotBridge m n p).symm ground)).trans - (Fragment.Equiv.relabelTrans _ _ _))) - (Fragment.foldSurvivingPermEquiv - ((mapPairs_symm_cancel (rotBridge m n p).symm - (Fragment.inrPairs (α := Fin (m + n)) - (hkPairs m n p))).symm ▸ - List.Perm.refl _)).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 - ((Fragment.Equiv.relabelFlip' - (Fragment.glueListEqEquiv (UPB.relabel MR) - (mapPairs_symm_cancel MR (rotQ3 m n p)).symm - wfq3 (Fragment.mapPairs_wf MR _ wfq4) - ((mapPairs_symm_cancel MR (rotQ3 m n p)).symm ▸ - List.Perm.refl _))).trans - ((Fragment.Equiv.relabelCongr - ((Fragment.glueListRelabel UPB MR (rotQ4 m n p) - wfq4).trans - ((Fragment.Equiv.relabelCongr CRapp - (Fragment.foldSurvivingMapEquiv MR - (rotQ4 m n p))).trans - (Fragment.Equiv.relabelTrans _ _ _))) - (Fragment.foldSurvivingPermEquiv - ((mapPairs_symm_cancel MR (rotQ3 m n p)).symm ▸ - List.Perm.refl _)).symm).trans - (Fragment.Equiv.relabelTrans _ _ _))) + 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 : (F.disjUnion XKH).Equiv (XR.relabel i') := + 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 - ((Fragment.Equiv.relabelFlip' - (Fragment.glueListEqEquiv (XR.relabel i') - (mapPairs_symm_cancel i' (rotQ2 m n p)).symm - wfq2 (Fragment.mapPairs_wf i' _ wfq3) - ((mapPairs_symm_cancel i' (rotQ2 m n p)).symm ▸ - List.Perm.refl _))).trans - ((Fragment.Equiv.relabelCongr - ((Fragment.glueListRelabel XR i' (rotQ3 m n p) - wfq3).trans - ((Fragment.Equiv.relabelCongr CR5 - (Fragment.foldSurvivingMapEquiv i' - (rotQ3 m n p))).trans - (Fragment.Equiv.relabelTrans _ _ _))) - (Fragment.foldSurvivingPermEquiv - ((mapPairs_symm_cancel i' (rotQ2 m n p)).symm ▸ - List.Perm.refl _)).symm).trans - (Fragment.Equiv.relabelTrans _ _ _))) + 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 : N₂.Equiv (XKH.relabel M₂) := - (Fragment.glueListCongr - (Fragment.relabelDisjUnionRight K H - (transposeEquiv n p)) _ _).trans + 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).relabel sτ) - (mapPairs_symm_cancel sτ (interfacePairs m p n)).symm - (interfacePairs_wf m p n) - (Fragment.mapPairs_wf sτ _ - (Fragment.mapPairs_wf sτ.symm _ - (interfacePairs_wf m p n))) - ((mapPairs_symm_cancel sτ - (interfacePairs m p n)).symm ▸ + (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.glueListRelabel (K.disjUnion H) sτ - (Fragment.mapPairs sτ.symm (interfacePairs m p n)) - (Fragment.mapPairs_wf sτ.symm _ - (interfacePairs_wf m p n))).trans - ((Fragment.Equiv.relabelCongr - ((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 _ _ _))) - (Fragment.foldSurvivingMapEquiv sτ - (Fragment.mapPairs sτ.symm - (interfacePairs m p n)))).trans - (Fragment.Equiv.relabelTrans _ _ _))) + (Fragment.glueListSwap (K.disjUnion H) + (hkPairs m n p) (hkPairs_wf m n p)) (Fragment.foldSurvivingPermEquiv - ((mapPairs_symm_cancel sτ - (interfacePairs m p n)).symm ▸ + ((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 - ((Fragment.Equiv.relabelFlip' - (Fragment.glueListEqEquiv - ((F.disjUnion XKH).relabel - (_root_.Equiv.sumCongr - (_root_.Equiv.refl (Fin (m + n))) M₂)) - (mapPairs_symm_cancel - (_root_.Equiv.sumCongr - (_root_.Equiv.refl (Fin (m + n))) M₂) - (rotQ1 m n p)).symm - wfq1 - (Fragment.mapPairs_wf - (_root_.Equiv.sumCongr - (_root_.Equiv.refl (Fin (m + n))) M₂) _ wfq2) - ((mapPairs_symm_cancel - (_root_.Equiv.sumCongr - (_root_.Equiv.refl (Fin (m + n))) M₂) - (rotQ1 m n p)).symm ▸ - List.Perm.refl _))).trans - ((Fragment.Equiv.relabelCongr - ((Fragment.glueListRelabel (F.disjUnion XKH) - (_root_.Equiv.sumCongr - (_root_.Equiv.refl (Fin (m + n))) M₂) - (rotQ2 m n p) wfq2).trans - ((Fragment.Equiv.relabelCongr CR3 - (Fragment.foldSurvivingMapEquiv - (_root_.Equiv.sumCongr - (_root_.Equiv.refl (Fin (m + n))) M₂) - (rotQ2 m n p))).trans - (Fragment.Equiv.relabelTrans _ _ _))) - (Fragment.foldSurvivingPermEquiv - ((mapPairs_symm_cancel - (_root_.Equiv.sumCongr - (_root_.Equiv.refl (Fin (m + n))) M₂) - (rotQ1 m n p)).symm ▸ - List.Perm.refl _)).symm).trans - (Fragment.Equiv.relabelTrans _ _ _))) + ((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 : ((F.relabel - (finCongr (by omega : m + n = 0 + (m + n)))).disjUnion - ((K.compose (H.relabel (transposeEquiv n p))).relabel - (finCongr (by omega : m + n = m + n + 0)))).Equiv - ((F.disjUnion N₂).relabel σR) := - (Fragment.relabelDisjUnionLeft F - ((K.compose (H.relabel (transposeEquiv n p))).relabel - (finCongr (by omega : m + n = m + n + 0))) - (finCongr (by omega : m + n = 0 + (m + n)))).trans - ((Fragment.Equiv.relabelCongr - (Fragment.relabelDisjUnionRight F - (K.compose (H.relabel (transposeEquiv n p))) - (finCongr (by omega : m + n = m + n + 0))) - (_root_.Equiv.sumCongr - (finCongr (by omega : m + n = 0 + (m + n))) - (_root_.Equiv.refl _))).trans - ((Fragment.Equiv.relabelTrans _ _ _).trans - ((Fragment.Equiv.relabelCongr - ((Fragment.Equiv.disjUnionCongr (Fragment.Equiv.refl F) - (composeNormal K (H.relabel (transposeEquiv n p)))).trans - (Fragment.relabelDisjUnionRight F N₂ - ((interfaceSurvEquiv m p n).trans finSumFinEquiv))) - ((_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 _)))).trans - (Fragment.Equiv.relabelTrans _ _ _)))) + 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 - ((Fragment.Equiv.relabelFlip' - (Fragment.glueListEqEquiv ((F.disjUnion N₂).relabel σR) - (mapPairs_symm_cancel σR - (interfacePairs 0 (m + n) 0)).symm - (interfacePairs_wf 0 (m + n) 0) - (Fragment.mapPairs_wf σR _ wfq1) - ((mapPairs_symm_cancel σR - (interfacePairs 0 (m + n) 0)).symm ▸ - List.Perm.refl _))).trans - ((Fragment.Equiv.relabelCongr - ((Fragment.glueListRelabel (F.disjUnion N₂) σR - (rotQ1 m n p) wfq1).trans - ((Fragment.Equiv.relabelCongr CR2 - (Fragment.foldSurvivingMapEquiv σR - (rotQ1 m n p))).trans - (Fragment.Equiv.relabelTrans _ _ _))) - (Fragment.foldSurvivingPermEquiv - ((mapPairs_symm_cancel σR - (interfacePairs 0 (m + n) 0)).symm ▸ - List.Perm.refl _)).symm).trans - (Fragment.Equiv.relabelTrans _ _ _))) + (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)))) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotateLeft.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotateLeft.lean index 55fc0863d8..864a563ee3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotateLeft.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotateLeft.lean @@ -78,7 +78,7 @@ private theorem wk_pullback_aux (s t u : ℕ) : refine congrArg₂ List.cons (Prod.ext ?_ rfl) (wk_pullback_aux s t u l) - show Sum.inl + change Sum.inl ((transposeEquiv s t).symm ⟨t + j.val, _⟩) = _ exact congrArg Sum.inl @@ -578,7 +578,7 @@ theorem leftRot_q4_eq (s t u : ℕ) : Fragment.liftPairs _ _ ((leftRotPairsR_wf s t u ).append_sep) := by - show Fragment.mapPairs + change Fragment.mapPairs (leftRotMR s t u).symm (Fragment.mapPairs (Fragment.inrFoldEquiv @@ -668,6 +668,11 @@ noncomputable def leftRotLabelR (s t u : ℕ) : /-! ### 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, @@ -713,7 +718,7 @@ noncomputable def leftRotNormalRight Fragment.mapPairs_wf i'.symm _ wfq2 let wfq4 : Fragment.PairsWF (leftRotQ4 s t u) := - Fragment.mapPairs_wf MR.symm _ wfq3 + leftRotQ4_wf s t u let A := (W.disjUnion F).disjUnion K let XWK := Fragment.glueList (W.disjUnion K) (wkPairs s t u) @@ -746,21 +751,7 @@ noncomputable def leftRotNormalRight -- `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.glueList UMB - (leftRotQ4 s t u) wfq4).Equiv - ((Fragment.glueList A - (mBlock s t u ++ - (pBlock s t u ++ - nBlockSwap s t u)) - (leftRotPairsR_wf s t u)).relabel - ((Fragment.appendFlatten _ _ - ((leftRotPairsR_wf s t u - ).append_sep)).symm.trans - (Fragment.foldSurvivingPermEquiv - ((leftRot_q4_eq s t u) ▸ - List.Perm.refl _ - )).symm)) := + have CRapp := (Fragment.Equiv.relabelFlip' (Fragment.glueListEqEquiv UMB (leftRot_q4_eq s t u) @@ -784,10 +775,7 @@ noncomputable def leftRotNormalRight List.Perm.refl _)).symm).trans (Fragment.Equiv.relabelTrans _ _ _)) -- BE: the ambient bridge. - have BE : A.Equiv - ((F.disjUnion - (W.disjUnion K)).relabel - (leftRotBridge s t u)) := + have BE := (Fragment.Equiv.disjUnionCongr (Fragment.disjUnionComm W F) (Fragment.Equiv.refl K)).trans @@ -805,96 +793,23 @@ noncomputable def leftRotNormalRight (Fin (s + u))))).trans (Fragment.Equiv.relabelTrans _ _ _))) -- CRX: the ambient bridge on the m-fold. - have CRX : XR.Equiv (UMB.relabel MR) := - (Fragment.glueListCongr - (Fragment.Equiv.relabelFlip BE) - _ _).trans - ((Fragment.Equiv.relabelFlip' - (Fragment.glueListEqEquiv - (A.relabel - (leftRotBridge s t u).symm) - (mapPairs_symm_cancel - (leftRotBridge s t u).symm - (Fragment.inrPairs - (α := Fin (t + u)) - (wkPairs s t u))).symm - (Fragment.inrPairs_wf _ - (wkPairs_wf s t u)) - (Fragment.mapPairs_wf - (leftRotBridge s t u).symm _ - wfground) - ((mapPairs_symm_cancel - (leftRotBridge s t u).symm - (Fragment.inrPairs - (α := Fin (t + u)) - (wkPairs s t u))).symm ▸ - List.Perm.refl _))).trans - ((Fragment.Equiv.relabelCongr - ((Fragment.glueListRelabel A - (leftRotBridge s t u).symm - ground wfground).trans - ((Fragment.Equiv.relabelCongr - (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 _))) - (Fragment.foldSurvivingMapEquiv - (leftRotBridge s t u).symm - ground)).trans - (Fragment.Equiv.relabelTrans - _ _ _))) - (Fragment.foldSurvivingPermEquiv - ((mapPairs_symm_cancel - (leftRotBridge s t u).symm - (Fragment.inrPairs - (α := Fin (t + u)) - (wkPairs s t u))).symm ▸ - List.Perm.refl _ - )).symm).trans - (Fragment.Equiv.relabelTrans _ _ _))) + 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 - ((Fragment.Equiv.relabelFlip' - (Fragment.glueListEqEquiv - (UMB.relabel MR) - (mapPairs_symm_cancel MR - (leftRotQ3 s t u)).symm - wfq3 - (Fragment.mapPairs_wf MR _ wfq4) - ((mapPairs_symm_cancel MR - (leftRotQ3 s t u)).symm ▸ - List.Perm.refl _))).trans - ((Fragment.Equiv.relabelCongr - ((Fragment.glueListRelabel UMB MR - (leftRotQ4 s t u) wfq4).trans - ((Fragment.Equiv.relabelCongr - CRapp - (Fragment.foldSurvivingMapEquiv - MR - (leftRotQ4 s t u))).trans - (Fragment.Equiv.relabelTrans - _ _ _))) - (Fragment.foldSurvivingPermEquiv - ((mapPairs_symm_cancel MR - (leftRotQ3 s t u)).symm ▸ - List.Perm.refl _ - )).symm).trans - (Fragment.Equiv.relabelTrans - _ _ _))) + 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 : - (F.disjUnion XWK).Equiv - (XR.relabel i') := + have E5 := (Fragment.Equiv.relabelFlip (Fragment.glueListDisjUnionRight F (W.disjUnion K) (wkPairs s t u) @@ -902,247 +817,39 @@ noncomputable def leftRotNormalRight (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 - ((Fragment.Equiv.relabelFlip' - (Fragment.glueListEqEquiv - (XR.relabel i') - (mapPairs_symm_cancel i' - (leftRotQ2 s t u)).symm - wfq2 - (Fragment.mapPairs_wf i' _ wfq3) - ((mapPairs_symm_cancel i' - (leftRotQ2 s t u)).symm ▸ - List.Perm.refl _))).trans - ((Fragment.Equiv.relabelCongr - ((Fragment.glueListRelabel XR i' - (leftRotQ3 s t u) wfq3).trans - ((Fragment.Equiv.relabelCongr - CR5 - (Fragment.foldSurvivingMapEquiv - i' - (leftRotQ3 s t u))).trans - (Fragment.Equiv.relabelTrans - _ _ _))) - (Fragment.foldSurvivingPermEquiv - ((mapPairs_symm_cancel i' - (leftRotQ2 s t u)).symm ▸ - List.Perm.refl _ - )).symm).trans - (Fragment.Equiv.relabelTrans - _ _ _))) + 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 : N₂.Equiv (XWK.relabel M₂) := - (Fragment.glueListCongr - (Fragment.relabelDisjUnionLeft - W K (transposeEquiv s t)) - _ _).trans - ((Fragment.Equiv.relabelFlip' - (Fragment.glueListEqEquiv - ((W.disjUnion K).relabel sτ) - (mapPairs_symm_cancel sτ - (interfacePairs t s u)).symm - (interfacePairs_wf t s u) - (Fragment.mapPairs_wf sτ _ - (Fragment.mapPairs_wf sτ.symm _ - (interfacePairs_wf t s u))) - ((mapPairs_symm_cancel sτ - (interfacePairs t s u)).symm ▸ - List.Perm.refl _))).trans - ((Fragment.Equiv.relabelCongr - ((Fragment.glueListRelabel - (W.disjUnion K) sτ - (Fragment.mapPairs sτ.symm - (interfacePairs t s u)) - (Fragment.mapPairs_wf sτ.symm _ - (interfacePairs_wf t s u - ))).trans - ((Fragment.Equiv.relabelCongr - (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 _))) - (Fragment.foldSurvivingMapEquiv - sτ - (Fragment.mapPairs sτ.symm - (interfacePairs t s u - )))).trans - (Fragment.Equiv.relabelTrans - _ _ _))) - (Fragment.foldSurvivingPermEquiv - ((mapPairs_symm_cancel sτ - (interfacePairs t s u)).symm ▸ - List.Perm.refl _ - )).symm).trans - (Fragment.Equiv.relabelTrans - _ _ _))) + 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 - ((Fragment.Equiv.relabelFlip' - (Fragment.glueListEqEquiv - ((F.disjUnion XWK).relabel - (_root_.Equiv.sumCongr - (_root_.Equiv.refl - (Fin (t + u))) M₂)) - (mapPairs_symm_cancel - (_root_.Equiv.sumCongr - (_root_.Equiv.refl - (Fin (t + u))) M₂) - (leftRotQ1 s t u)).symm - wfq1 - (Fragment.mapPairs_wf - (_root_.Equiv.sumCongr - (_root_.Equiv.refl - (Fin (t + u))) M₂) _ - wfq2) - ((mapPairs_symm_cancel - (_root_.Equiv.sumCongr - (_root_.Equiv.refl - (Fin (t + u))) M₂) - (leftRotQ1 s t u)).symm ▸ - List.Perm.refl _))).trans - ((Fragment.Equiv.relabelCongr - ((Fragment.glueListRelabel - (F.disjUnion XWK) - (_root_.Equiv.sumCongr - (_root_.Equiv.refl - (Fin (t + u))) M₂) - (leftRotQ2 s t u) wfq2).trans - ((Fragment.Equiv.relabelCongr - CR3 - (Fragment.foldSurvivingMapEquiv - (_root_.Equiv.sumCongr - (_root_.Equiv.refl - (Fin (t + u))) M₂) - (leftRotQ2 s t u))).trans - (Fragment.Equiv.relabelTrans - _ _ _))) - (Fragment.foldSurvivingPermEquiv - ((mapPairs_symm_cancel - (_root_.Equiv.sumCongr - (_root_.Equiv.refl - (Fin (t + u))) M₂) - (leftRotQ1 s t u)).symm ▸ - List.Perm.refl _ - )).symm).trans - (Fragment.Equiv.relabelTrans - _ _ _))) + 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 : - ((F.relabel (finCongr - (by omega : t + u = 0 + (t + u) - ))).disjUnion - (((W.relabel - (transposeEquiv s t)).compose - K).relabel (finCongr - (by omega : - t + u = t + u + 0)))).Equiv - ((F.disjUnion N₂).relabel σR) := - (Fragment.relabelDisjUnionLeft F - (((W.relabel - (transposeEquiv s t)).compose - K).relabel (finCongr - (by omega : t + u = t + u + 0))) - (finCongr - (by omega : - t + u = 0 + (t + u)))).trans - ((Fragment.Equiv.relabelCongr - (Fragment.relabelDisjUnionRight F - ((W.relabel - (transposeEquiv s t)).compose - K) - (finCongr - (by omega : - t + u = t + u + 0))) - (_root_.Equiv.sumCongr - (finCongr - (by omega : - t + u = 0 + (t + u))) - (_root_.Equiv.refl _))).trans - ((Fragment.Equiv.relabelTrans - _ _ _).trans - ((Fragment.Equiv.relabelCongr - ((Fragment.Equiv.disjUnionCongr - (Fragment.Equiv.refl F) - (composeNormal - (W.relabel - (transposeEquiv s t)) K - )).trans - (Fragment.relabelDisjUnionRight - F N₂ - ((interfaceSurvEquiv t s u).trans - finSumFinEquiv))) - ((_root_.Equiv.sumCongr - (_root_.Equiv.refl - (Fin (t + u))) - (finCongr - (by omega : - t + u = t + u + 0))).trans - (_root_.Equiv.sumCongr - (finCongr - (by omega : - t + u = 0 + (t + u))) - (_root_.Equiv.refl _)))).trans - (Fragment.Equiv.relabelTrans - _ _ _)))) + have E1 := pairCloseAmbientEquiv F _ (composeNormal (W.relabel (transposeEquiv s t)) K) -- CR1: transport the closure gluing. - have CR1 := - (Fragment.glueListCongr E1 + 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 - )).trans - ((Fragment.Equiv.relabelFlip' - (Fragment.glueListEqEquiv - ((F.disjUnion N₂).relabel σR) - (mapPairs_symm_cancel σR - (interfacePairs 0 - (t + u) 0)).symm - (interfacePairs_wf 0 (t + u) 0) - (Fragment.mapPairs_wf σR _ - wfq1) - ((mapPairs_symm_cancel σR - (interfacePairs 0 - (t + u) 0)).symm ▸ - List.Perm.refl _))).trans - ((Fragment.Equiv.relabelCongr - ((Fragment.glueListRelabel - (F.disjUnion N₂) σR - (leftRotQ1 s t u) wfq1).trans - ((Fragment.Equiv.relabelCongr - CR2 - (Fragment.foldSurvivingMapEquiv - σR - (leftRotQ1 s t u))).trans - (Fragment.Equiv.relabelTrans - _ _ _))) - (Fragment.foldSurvivingPermEquiv - ((mapPairs_symm_cancel σR - (interfacePairs 0 - (t + u) 0)).symm ▸ - List.Perm.refl _ - )).symm).trans - (Fragment.Equiv.relabelTrans - _ _ _))) + (interfacePairs_wf 0 (t + u) 0) CR2) -- Assemble. -- ═══════ ASSEMBLY ═══════ exact (composeNormal @@ -1300,6 +1007,11 @@ theorem leftRot_surv_empty (s t u : ℕ) /-! ### The final theorem -/ +private theorem leftRotPairs_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 (leftRotPairs_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. -/ @@ -1337,7 +1049,7 @@ noncomputable def pairCloseComposeRotateLeft have wf_MA : Fragment.PairsWF (mp ++ nBlock s t u) := - hassocM ▸ wf_M + leftRotPairs_assoc_wf s t u have hassocR : mp ++ nBlockSwap s t u = mBlock s t u ++ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseUnion.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseUnion.lean index 12dda4aab3..2cab957ddd 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseUnion.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseUnion.lean @@ -274,7 +274,7 @@ theorem fragTrace_tensor {R : ℕ} (f : EdgeRankParameter R) (strandBundle b))).trans (pairCloseUnionRight F₁ (strandBundle a) (pairClose F₂ (strandBundle b))))) - show f.val (pairClose (tensorFragment F₁ F₂) + change f.val (pairClose (tensorFragment F₁ F₂) (strandBundle (a + b))) = _ rw [f.iso_invariant _ _ E, EdgeRankParameter.val_union] rfl diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedAgreement.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedAgreement.lean index c132b1b6f2..b8f9bba2de 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedAgreement.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedAgreement.lean @@ -24,7 +24,7 @@ This is the base case of the converse's factorization induction. namespace RS -open scoped Classical + variable {W : ClosedFragment} @@ -33,7 +33,7 @@ variable {W : ClosedFragment} /-- On a closed fragment, no flag is boundary-attached. -/ theorem EdgeSubset.allInternal_of_closed (F : EdgeSubset W) : F.allInternal := by - show F.boundaryFlags = ∅ + change F.boundaryFlags = ∅ rw [Finset.eq_empty_iff_forall_notMem] intro f hf exact Fin.elim0 (F.attach_boundary_of_mem hf).choose @@ -232,7 +232,7 @@ theorem EdgeSubset.throughSummand_eq_mixedSummand rw [mul_one] congr 1 refine Finset.sum_congr rfl fun ψ _ => ?_ - rw [if_pos (genEvenBoundaryMatch_closed F st hbnd ψ)] + rw [ite_eq_left (genEvenBoundaryMatch_closed F st hbnd ψ)] refine (Fintype.sum_equiv (F.coreOddEquiv ℓ) (fun φ_core => if F.coreOddBoundaryMatch st φ_core then @@ -247,7 +247,7 @@ theorem EdgeSubset.throughSummand_eq_mixedSummand h.evalOdd (F.evenColoursAt ψ v) (F.oddListAt o φ v))) (fun φ_core => ?_)) - rw [if_pos (F.coreOddBoundaryMatch_closed st φ_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] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedCutDispatch.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedCutDispatch.lean index 1dcc58b2ab..fc16f6fc3f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedCutDispatch.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedCutDispatch.lean @@ -21,7 +21,7 @@ for step, and that the path matching is carried across unchanged. namespace RS -open scoped Classical + open Fragment namespace EdgeSubset @@ -131,7 +131,7 @@ theorem iterWalk_unglueClosed_val_all (δ' : SurvivingFlag W i j) : induction t with | zero => rfl | succ t ih => - show (κW).match_ (W.pairing (iterWalk (κW) δ'.val t)) = + change (κW).match_ (W.pairing (iterWalk (κW) δ'.val t)) = (κ'.match_ ((W.gluePairClosed i j hclosed).pairing (iterWalk κ' δ' t))).val rw [ih] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedIdentify.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedIdentify.lean index 49f2f16b26..89aadbd77c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedIdentify.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedIdentify.lean @@ -27,8 +27,7 @@ namespace RS namespace EdgeSubset -open Fragment Classical - +open Fragment section Indep variable {L : Type} @@ -103,7 +102,7 @@ theorem mixedValue_relabelUp_closed [LinearOrder L] {V : Fragment L} (Classical.choice hne') ⟨relabelTransUp e.toEquiv F d.1, ⟨relabelOrientUp e.toEquiv F d.2.val, hcan⟩⟩] - show (F.relabelUp e.toEquiv).throughSummand h _ hbnd' + 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] @@ -143,8 +142,8 @@ theorem mixedPartition_relabel_orderIso 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 (dif_pos hc) (Eq.trans ?_ (dif_pos hc).symm) - refine Eq.trans ?_ (dif_pos hbnd).symm + 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 := @@ -158,8 +157,8 @@ theorem mixedPartition_relabel_orderIso have hne : Nonempty (EdgeSubset.mk s hc : EdgeSubset V).CanonData := ⟨⟨κ.toRelTransitionSystem, o.toRel, hcan⟩⟩ - refine Eq.trans (if_pos hE') (Eq.trans ?_ (if_pos hE).symm) - refine Eq.trans ?_ (dif_pos hne).symm + 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) @@ -171,11 +170,11 @@ theorem mixedPartition_relabel_orderIso EdgeSubset (V.relabel e.toEquiv)).Eulerian := fun hx => hE ((relabelUp_eulerian e.toEquiv (EdgeSubset.mk s hc)).mp hx) - refine Eq.trans (if_neg hE') ?_ - exact (if_neg hE).symm - · refine Eq.trans (dif_neg hc) ?_ + refine Eq.trans (ite_eq_right hE') ?_ + exact (ite_eq_right hE).symm + · refine Eq.trans (dite_eq_right hc) ?_ symm - exact dif_neg hc + exact dite_eq_right hc open Classical in /-- **The relabelled fragment's Definition 5 partition value is the diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.lean index 4f5cf6050c..a20e71bcb6 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.lean @@ -21,8 +21,7 @@ namespace RS namespace EdgeSubset -open Fragment Classical - +open Fragment variable {L : Type} open Classical in @@ -49,7 +48,7 @@ theorem circuitWeight_pos [LinearOrder L] {V : Fragment L} circuitWeight 𝒟 s = ((-1 : ℂ) ^ (𝒟 s hc hE hne).1.openCircuitCount) := by unfold circuitWeight - rw [dif_pos hc, dif_pos hE, dif_pos hne] + rw [dite_eq_left hc, dite_eq_left hE, dite_eq_left hne] section ClosedTop diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean index 9055fec0f1..47f07cca83 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean @@ -28,8 +28,7 @@ namespace RS namespace EdgeSubset -open Fragment Classical - +open Fragment section OpenCut variable {L : Type} {V : Fragment L} {i j : L} @@ -211,7 +210,7 @@ theorem sum_odd_miss by_cases hm : edgeOddBoundaryMatch (Fl) (GenBoundaryState.extendPair i j st' (Sum.inl a) (Sum.inl a)) φ - · rw [if_pos hm, if_pos ((edgeOddBoundaryMatch_miss hij hopen t + · 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 @@ -219,7 +218,7 @@ theorem sum_odd_miss (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 [if_neg hm, if_neg (fun hx => hm + · rw [ite_eq_right hm, ite_eq_right (fun hx => hm ((edgeOddBoundaryMatch_miss hij hopen t hct hcL hni st' a φ).mpr hx))] @@ -273,10 +272,10 @@ theorem edgeSum_openCut_miss (GenBoundaryState.extendPair i j st' (Sum.inl a) (Sum.inl a)) (hbndW a) (evenPushOpen hij hopen t hct hcL hni ψ') - · rw [if_pos hg, if_pos ((genEvenBoundaryMatch_open_iff hij + · 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 [if_neg hg, if_neg (fun hx => hg + · 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), @@ -284,13 +283,13 @@ theorem edgeSum_openCut_miss unfold edgeSum refine Finset.sum_congr rfl (fun ψ' _ => ?_) by_cases hg : genEvenBoundaryMatch (Fg) st' hbnd' ψ' - · rw [if_pos hg, Finset.sum_eq_single + · rw [ite_eq_left hg, Finset.sum_eq_single (ψ'.val ⟨partnerSurvI hopen, hni⟩) - (fun a _ hne => if_neg (fun hx => hne hx.1.symm)) - (fun hx => absurd (Finset.mem_univ _) hx), if_pos ⟨rfl, hg⟩] + (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 [if_neg hg] - exact Finset.sum_eq_zero (fun a _ => if_neg (fun hx => hg hx.2)) + · rw [ite_eq_right hg] + exact Finset.sum_eq_zero (fun a _ => ite_eq_right (fun hx => hg hx.2)) end MissSum @@ -435,7 +434,7 @@ theorem oddPushHitFun_at_i {ℓ : ℕ} 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⟩ := dif_pos rfl + = φ'.val ⟨partnerSurvI hopen, hpi⟩ := dite_eq_left rfl include hij in /-- At the second it takes the same colour: the two ends of the @@ -447,8 +446,8 @@ theorem oddPushHitFun_at_j {ℓ : ℕ} oddPushHitFun hij hopen t hct hpi φ' ⟨V.boundaryFlag j, hP⟩ = φ'.val ⟨partnerSurvI hopen, hpi⟩ := by unfold oddPushHitFun - rw [dif_neg (fun hEq => hij (V.boundaryFlag_injective hEq).symm), - dif_pos rfl] + 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. -/ @@ -460,7 +459,7 @@ theorem oddPushHitFun_agrees {ℓ : ℕ} oddPushHitFun hij hopen t hct hpi φ' ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩ := by unfold oddPushHitFun - rw [dif_neg g.prop.1, dif_neg g.prop.2] + 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. -/ @@ -480,7 +479,7 @@ noncomputable def oddPushHit {ℓ : ℕ} mem_lift_of_mem hopen t hpi⟩ from Subtype.ext hpv, oddPushHitFun_agrees hij hopen t hct hpi φ' (partnerSurvI hopen) _ hpi] - show _ = oddPushHitFun hij hopen t hct hpi φ' ⟨f.val, f.prop⟩ + 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, @@ -501,7 +500,7 @@ noncomputable def oddPushHit {ℓ : ℕ} (partnerSurvJ hopen) _ (partnerSurvJ_mem_of_hit hij hopen t hct hpi), glued_odd_merged hij hopen t hct hpi φ'] - show _ = oddPushHitFun hij hopen t hct hpi φ' ⟨f.val, f.prop⟩ + 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, @@ -740,7 +739,7 @@ theorem oddPushHit_covers {k ℓ : ℕ} rw [h1] exact φW.prop ⟨g.val.val, hmC⟩ · refine Subtype.ext (funext fun f => ?_) - show oddPushHitFun hij hopen t hct hpi _ f = φW.val 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] @@ -837,7 +836,7 @@ theorem sum_odd_hit {k ℓ : ℕ} (Sum.inr d)) φW then G φW else 0) := by refine (Finset.sum_subset (Finset.subset_univ _) ?_).symm intro φW _ hnotim - rw [if_neg (fun hmatch => 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φ'⟩ @@ -913,7 +912,7 @@ theorem edgeSum_openCut_hit (fun ψ' => ?_)).symm by_cases hg : genEvenBoundaryMatch (EdgeSubset.mk t hct : EdgeSubset (V.gluePairOpen i j hij hopen)) st' hbnd' ψ' - · rw [if_pos hg, if_pos ((genEvenBoundaryMatch_hit_iff hij hopen + · 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, @@ -933,8 +932,8 @@ theorem edgeSum_openCut_hit by_cases hp : (φ'.val ⟨partnerSurvI hopen, hpi⟩ = d ∧ edgeOddBoundaryMatch (EdgeSubset.mk t hct : EdgeSubset (V.gluePairOpen i j hij hopen)) st' φ') - · rw [if_pos ((edgeOddBoundaryMatch_hit_iff hij hopen t hct - hcL hpi st' d φ').mpr hp), if_pos hp] + · 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 ψ') @@ -943,9 +942,9 @@ theorem edgeSum_openCut_hit (oddPushHit hij hopen t hct hcL hpi φ').core φ'.core (fun g h1 h2 => oddPushHitFun_agrees hij hopen t hct hpi φ' g _ _) v).symm - · rw [if_neg (fun hx => hp ((edgeOddBoundaryMatch_hit_iff hij - hopen t hct hcL hpi st' d φ').mp hx)), if_neg hp] - · rw [if_neg hg, if_neg (fun hx => hg + · 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 ═══════ @@ -955,19 +954,19 @@ theorem edgeSum_openCut_hit 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 [if_pos hg] + · 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 [if_pos hp, Finset.sum_eq_single + · rw [ite_eq_left hp, Finset.sum_eq_single (φ'.val ⟨partnerSurvI hopen, hpi⟩) - (fun d _ hne => if_neg (fun hx => hne hx.1.symm)) - (fun hx => absurd (Finset.mem_univ _) hx), if_pos ⟨rfl, hp⟩] + (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 [if_neg hp] - exact Finset.sum_eq_zero (fun d _ => if_neg (fun hx => hp hx.2)) - · simp only [if_neg hg] + · 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 @@ -1126,7 +1125,7 @@ theorem evenPushClosedFalseFun_at_i {k : ℕ} (a : Fin k) 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 := dif_pos rfl + ⟨V.boundaryFlag i, hP⟩ = a := dite_eq_left rfl include hij in /-- At the second it takes the same colour. -/ @@ -1137,8 +1136,8 @@ theorem evenPushClosedFalseFun_at_j {k : ℕ} (a : Fin k) evenPushClosedFalseFun hclosed t hct a ψ' ⟨V.boundaryFlag j, hP⟩ = a := by unfold evenPushClosedFalseFun - rw [dif_neg (fun hEq => hij (V.boundaryFlag_injective hEq).symm), - dif_pos rfl] + 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. -/ @@ -1150,7 +1149,7 @@ theorem evenPushClosedFalseFun_agrees {k : ℕ} (a : Fin k) evenPushClosedFalseFun hclosed t hct a ψ' ⟨g.val, h1⟩ = ψ'.val ⟨g, h2⟩ := by unfold evenPushClosedFalseFun - rw [dif_neg g.prop.1, dif_neg g.prop.2] + 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. -/ @@ -1336,7 +1335,7 @@ theorem evenPushClosedFalse_covers {k ℓ : ℕ} rw [h1] exact ψW.prop ⟨g.val.val, hmC⟩ · refine Subtype.ext (funext fun f => ?_) - show evenPushClosedFalseFun hclosed t hct a _ f = ψW.val 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] @@ -1399,7 +1398,7 @@ theorem sum_even_closed_false {k ℓ : ℕ} (Sum.inl a)) hbndW ψW then G ψW else 0) := by refine (Finset.sum_subset (Finset.subset_univ _) ?_).symm intro ψW _ hnotim - rw [if_neg (fun hmatch => 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ψ'⟩ @@ -1451,8 +1450,8 @@ theorem edgeSum_closedCut_false refine Finset.sum_congr rfl (fun ψ' _ => ?_) by_cases hg : genEvenBoundaryMatch (EdgeSubset.mk t hct : EdgeSubset (V.gluePairClosed i j hclosed)) st' hbnd' ψ' - · rw [if_pos ((genEvenBoundaryMatch_closedFalse_iff hij hclosed t - hct hcL st' a hbndW hbnd' ψ').mpr hg), if_pos hg] + · 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 φ => ?_) @@ -1460,7 +1459,7 @@ theorem edgeSum_closedCut_false (EdgeSubset.mk (liftSubsetClosed t false) hcL) (GenBoundaryState.extendPair i j st' (Sum.inl a) (Sum.inl a)) φ - · rw [if_pos hm, if_pos ((edgeOddBoundaryMatch_closedFalse hij + · 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 @@ -1470,12 +1469,12 @@ theorem edgeSum_closedCut_false φ.core (oddColourEquivClosedFalse hij hclosed t hct hcL ℓ φ).core (fun g h1 h2 => congrArg φ.val (Subtype.ext rfl)) v - · rw [if_neg hm, if_neg (fun hx => hm + · rw [ite_eq_right hm, ite_eq_right (fun hx => hm ((edgeOddBoundaryMatch_closedFalse hij hclosed t hct hcL st' a φ).mpr hx))] - · rw [if_neg (fun hx => hg ((genEvenBoundaryMatch_closedFalse_iff + · rw [ite_eq_right (fun hx => hg ((genEvenBoundaryMatch_closedFalse_iff hij hclosed t hct hcL st' a hbndW hbnd' ψ').mp hx)), - if_neg hg] + ite_eq_right hg] end ClosedFalseSum @@ -1626,7 +1625,7 @@ theorem oddPushClosedTrueFun_at_i {ℓ : ℕ} (d : Fin (2 * ℓ)) EdgeSubset (V.gluePairClosed i j hclosed)).EdgeOddColouring ℓ) (hP : V.boundaryFlag i ∈ liftSubsetClosed t true) : oddPushClosedTrueFun hclosed t hct d φ' ⟨V.boundaryFlag i, hP⟩ - = d := dif_pos rfl + = d := dite_eq_left rfl include hij in /-- At the second it takes the same colour. -/ @@ -1637,8 +1636,8 @@ theorem oddPushClosedTrueFun_at_j {ℓ : ℕ} (d : Fin (2 * ℓ)) oddPushClosedTrueFun hclosed t hct d φ' ⟨V.boundaryFlag j, hP⟩ = d := by unfold oddPushClosedTrueFun - rw [dif_neg (fun hEq => hij (V.boundaryFlag_injective hEq).symm), - dif_pos rfl] + 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. -/ @@ -1650,7 +1649,7 @@ theorem oddPushClosedTrueFun_agrees {ℓ : ℕ} (d : Fin (2 * ℓ)) oddPushClosedTrueFun hclosed t hct d φ' ⟨g.val, h1⟩ = φ'.val ⟨g, h2⟩ := by unfold oddPushClosedTrueFun - rw [dif_neg g.prop.1, dif_neg g.prop.2] + 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. -/ @@ -1823,7 +1822,7 @@ theorem oddPushClosedTrue_covers {k ℓ : ℕ} rw [h1] exact φW.prop ⟨g.val.val, hmC⟩ · refine Subtype.ext (funext fun f => ?_) - show oddPushClosedTrueFun hclosed t hct d _ f = φW.val 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] @@ -1878,7 +1877,7 @@ theorem sum_odd_closed_true {k ℓ : ℕ} (Sum.inr d)) φW then G φW else 0) := by refine (Finset.sum_subset (Finset.subset_univ _) ?_).symm intro φW _ hnotim - rw [if_neg (fun hmatch => 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φ'⟩ @@ -1920,7 +1919,7 @@ theorem edgeSum_closedCut_true (fun ψ' => ?_)).symm by_cases hg : genEvenBoundaryMatch (EdgeSubset.mk t hct : EdgeSubset (V.gluePairClosed i j hclosed)) st' hbnd' ψ' - · rw [if_pos hg, if_pos ((genEvenBoundaryMatch_closedTrue_iff hij + · 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, @@ -1939,7 +1938,7 @@ theorem edgeSum_closedCut_true refine Finset.sum_congr rfl (fun φ' _ => ?_) by_cases hp : edgeOddBoundaryMatch (EdgeSubset.mk t hct : EdgeSubset (V.gluePairClosed i j hclosed)) st' φ' - · rw [if_pos hp, if_pos ((edgeOddBoundaryMatch_closedTrue_iff + · 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 @@ -1952,10 +1951,10 @@ theorem edgeSum_closedCut_true φ'.core (fun g h1 h2 => oddPushClosedTrueFun_agrees hclosed t hct d φ' g _ _) v).symm - · rw [if_neg hp, if_neg (fun hx => hp + · rw [ite_eq_right hp, ite_eq_right (fun hx => hp ((edgeOddBoundaryMatch_closedTrue_iff hij hclosed t hct hcT st' d φ').mp hx))] - · rw [if_neg hg, if_neg (fun hx => hg + · 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))] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean index d6cc675929..0da97f4ed3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean @@ -18,7 +18,7 @@ free-circle factor as well. namespace RS -open Classical + namespace MixedColourEmbedding @@ -96,7 +96,7 @@ theorem oddListAt_map (e : MixedColourEmbedding k ℓ K L) rw [List.map_flatMap] congr 1 funext a - simp [EdgeSubset.oddPairFn, oddColouring, e.partner_eq] + simp? [EdgeSubset.oddPairFn, oddColouring, e.partner_eq] exact ⟨rfl, rfl⟩ /-- The odd vertex sign is preserved by embedding colours. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourRecursion.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourRecursion.lean index 0b6fddf0e6..88996e99f8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourRecursion.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourRecursion.lean @@ -23,8 +23,7 @@ namespace RS namespace EdgeSubset -open Fragment Classical - +open Fragment /-! ## The base of the iteration At an empty interface the composition still relabels, between two @@ -116,7 +115,7 @@ theorem gluePair_eq_closed (hcl : V.pairing (V.boundaryFlag (cutL n)) V.gluePairClosed (cutL n) (cutR n) hcl = V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n) := by unfold Fragment.gluePair - rw [dif_pos hcl] + rw [dite_eq_left hcl] /-- The stage's glue, at an open cut. -/ theorem gluePair_eq_open (hop : V.pairing (V.boundaryFlag (cutL n)) @@ -124,7 +123,7 @@ theorem gluePair_eq_open (hop : V.pairing (V.boundaryFlag (cutL 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 [dif_neg hop] + 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 @@ -171,7 +170,7 @@ theorem edgeTermAt_stepOpen_all {k ℓ : ℕ} (h : MixedFunctional k ℓ) (dataOfEq (gluePair_eq_open n V hop) (stepDataGlued n V 𝒟)) := by unfold stepDataDown - rw [dif_neg hop] + 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 @@ -208,7 +207,7 @@ theorem edgeTermAt_stepClosed_false_all {k ℓ : ℕ} (dataOfEq (gluePair_eq_closed n V hcl) (stepDataGlued n V 𝒟)) := by unfold stepDataDown - rw [dif_pos hcl] + 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 @@ -246,7 +245,7 @@ theorem edgeTermAt_stepClosed_true_all {k ℓ : ℕ} (dataOfEq (gluePair_eq_closed n V hcl) (stepDataGlued n V 𝒟)) := by unfold stepDataDown - rw [dif_pos hcl] + 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 @@ -287,7 +286,7 @@ theorem edgeTermAt_stepClosed_all {k ℓ : ℕ} (dataOfEq (gluePair_eq_closed n V hcl) (stepDataGlued n V 𝒟)) := by unfold stepDataDown - rw [dif_pos hcl] + 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 @@ -388,23 +387,23 @@ theorem diagOf_succ {k ℓ : ℕ} (n : ℕ) (st := stageState n (diagOf n (fun a => x a.castSucc))) (c := x (Fin.last n)) (c' := x (Fin.last n)) (a := ⟨y, hL, hR⟩)] - show _ = diagOf n (fun a => x a.castSucc) + 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 ?_) - show (v : ℕ) = _ + 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 ?_) - show (w : ℕ) = _ + 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 [if_pos hlt] + rw [ite_eq_left hlt] open Classical in /-- **The carried count at an open stage** is the next stage's. -/ @@ -420,9 +419,9 @@ theorem carried_liftOpen (n : ℕ) (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 - show (if hcl : V.pairing (V.boundaryFlag (cutL n)) + change (if hcl : V.pairing (V.boundaryFlag (cutL n)) = V.boundaryFlag (cutR n) then _ else _) = _ - rw [dif_neg hop] + 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) @@ -444,9 +443,9 @@ theorem carried_liftClosed (n : ℕ) (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 - show (if hc : V.pairing (V.boundaryFlag (cutL n)) + change (if hc : V.pairing (V.boundaryFlag (cutL n)) = V.boundaryFlag (cutR n) then _ else _) = _ - rw [dif_pos hcl] + rw [dite_eq_left hcl] refine congrArg₂ (· + ·) ?_ ?_ · exact if_congr (boundaryFlagI_mem_liftClosed_iff (cutL_ne_cutR n) t b) rfl @@ -473,7 +472,7 @@ def snocEquiv (n : ℕ) (α : Type) : refine Fin.lastCases ?_ ?_ a <;> simp /-- **The interface colour sum, one cut at a time.** -/ -theorem sum_snoc {n : ℕ} {α : Type} [Fintype α] [DecidableEq α] +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 @@ -515,9 +514,9 @@ theorem imageOf_succ_open (n : ℕ) (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) (gluePair_eq_open n V hop) (V.dropSubset (cutL n) (cutR n) s)) := by - show (if hcl : V.pairing (V.boundaryFlag (cutL n)) + change (if hcl : V.pairing (V.boundaryFlag (cutL n)) = V.boundaryFlag (cutR n) then _ else _) = _ - exact dif_neg hop + exact dite_eq_right hop open Classical in /-- The image, one stage down, at a closing cut. -/ @@ -531,9 +530,9 @@ theorem imageOf_succ_closed (n : ℕ) (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)) (gluePair_eq_closed n V hcl) (V.dropSubset (cutL n) (cutR n) s)) := by - show (if hc : V.pairing (V.boundaryFlag (cutL n)) + change (if hc : V.pairing (V.boundaryFlag (cutL n)) = V.boundaryFlag (cutR n) then _ else _) = _ - exact dif_pos hcl + exact dite_eq_left hcl /-- Sums over the flags of identified fragments agree. -/ theorem sum_flagsOfEq {β : Type} {V₁ V₂ : Fragment β} @@ -620,9 +619,9 @@ theorem cutFactor_liftOpen (k ℓ : ℕ) (n : ℕ) (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 - show (if hcl : V.pairing (V.boundaryFlag (cutL n)) + change (if hcl : V.pairing (V.boundaryFlag (cutL n)) = V.boundaryFlag (cutR n) then _ else _) = _ - rw [dif_neg hop] + 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) @@ -644,9 +643,9 @@ theorem cutFactor_liftClosed (k ℓ : ℕ) (n : ℕ) (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 - show (if hc : V.pairing (V.boundaryFlag (cutL n)) + change (if hc : V.pairing (V.boundaryFlag (cutL n)) = V.boundaryFlag (cutR n) then _ else _) = _ - rw [dif_pos hcl] + rw [dite_eq_left hcl] refine congrArg₂ (· * ·) ?_ ?_ · exact if_congr (boundaryFlagI_mem_liftClosed_iff (cutL_ne_cutR n) t b) rfl @@ -855,10 +854,10 @@ theorem edgeTermAt_glueInterface {k ℓ : ℕ} = V.boundaryFlag (cutR n) · have hcc : closedCuts (n + 1) V = 1 + closedCuts n (stepFragment n V) := by - show (if V.pairing (V.boundaryFlag (cutL n)) + change (if V.pairing (V.boundaryFlag (cutL n)) = V.boundaryFlag (cutR n) then 1 else 0) + closedCuts n (stepFragment n V) = _ - rw [if_pos hcl] + rw [ite_eq_left hcl] rw [hcc, pow_add, pow_one, mul_assoc] refine Eq.trans (congrArg (fun z => ((k : ℂ) - 2 * ℓ) * z) ih) ?_ @@ -873,10 +872,10 @@ theorem edgeTermAt_glueInterface {k ℓ : ℕ} (congrArg w (imageOf_succ_closed n V hcl s).symm) · have hcc : closedCuts (n + 1) V = closedCuts n (stepFragment n V) := by - show (if V.pairing (V.boundaryFlag (cutL n)) + change (if V.pairing (V.boundaryFlag (cutL n)) = V.boundaryFlag (cutR n) then 1 else 0) + closedCuts n (stepFragment n V) = _ - rw [if_neg hcl, Nat.zero_add] + rw [ite_eq_right hcl, Nat.zero_add] rw [hcc] refine Eq.trans ih ?_ refine Eq.trans (stageSum_open h n V diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeAssoc.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeAssoc.lean index 6bc6866557..b64b3d05c5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeAssoc.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeAssoc.lean @@ -38,19 +38,19 @@ noncomputable def disjUnionAssoc (W₁ : Fragment α) vertexEquiv := _root_.Equiv.sumAssoc W₁.Vertex W₂.Vertex W₃.Vertex attach_comm f := by rcases f with (f | f) | f - · show ((W₁.attach f).map Sum.inl Sum.inl).map id + · 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 - · show (((W₂.attach f).map Sum.inl Sum.inl).map Sum.inr + · 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 - · show (((W₃.attach f).map Sum.inr Sum.inr).map Sum.inr + · 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 @@ -58,7 +58,7 @@ noncomputable def disjUnionAssoc (W₁ : Fragment α) pairing_comm f := by rcases f with (f | f) | f <;> rfl circles_eq := by - show W₁.circles + W₂.circles + W₃.circles = + change W₁.circles + W₂.circles + W₃.circles = W₁.circles + (W₂.circles + W₃.circles) omega @@ -73,12 +73,12 @@ noncomputable def relabelDisjUnionLeft {α' : Type} vertexEquiv := _root_.Equiv.refl _ attach_comm f := by rcases f with f | f - · show ((W.attach f).map Sum.inl Sum.inl).map id + · 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 - · show ((W'.attach f).map Sum.inr Sum.inr).map id + · 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 @@ -97,12 +97,12 @@ noncomputable def relabelDisjUnionRight {β' : Type} vertexEquiv := _root_.Equiv.refl _ attach_comm f := by rcases f with f | f - · show ((W.attach f).map Sum.inl Sum.inl).map id + · 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 - · show ((W'.attach f).map Sum.inr Sum.inr).map id + · 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 @@ -268,7 +268,7 @@ theorem interfaceEquiv_symm_high (s t u : ℕ) (k : ℕ) (_hk : k < 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 show t ≤ t + k; omega) + (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)) @@ -278,9 +278,9 @@ theorem interfaceEquiv_symm_high (s t u : ℕ) (k : ℕ) (_hk : k < u) (⟨Sum.inr ⟨t + k, h2⟩, hsurv⟩ : Fragment.FoldSurviving (Fin (s + t) ⊕ Fin (t + u)) (interfacePairs s t u)) - ⟨t + k, h2⟩ rfl (by show t ≤ t + k; omega)) + ⟨t + k, h2⟩ rfl (by change t ≤ t + k; omega)) rw [finSumFinEquiv_apply_right] at h3 - exact h3.trans (Fin.ext (by show s + (t + k - t) = s + k; omega)) + 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) @@ -444,6 +444,47 @@ noncomputable def glueListProofIrrel (W : Fragment α) 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: @@ -652,6 +693,15 @@ theorem rhs_pairs_eq (s t u v : ℕ) (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 @@ -675,7 +725,7 @@ noncomputable def assocNormalLeft {s t u v : ℕ} let wfps' : Fragment.PairsWF ps' := Fragment.mapPairs_wf σ.symm _ (interfacePairs_wf s u v) let wfps'' : Fragment.PairsWF ps'' := - Fragment.mapPairs_wf i.symm _ wfps' + lhsOuterPairs_wf s t u v let A := (F.disjUnion G).disjUnion H let X := Fragment.glueList A (Fragment.inlPairs (interfacePairs s t u)) @@ -683,17 +733,7 @@ noncomputable def assocNormalLeft {s t u v : ℕ} 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.glueList X ps'' wfps'').Equiv - ((Fragment.glueList A - (Fragment.inlPairs (interfacePairs s t u) ++ - uPairsAssoc s t u v) - (assocPairs_wf s t u v)).relabel - ((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)) := + have C8 := (Fragment.Equiv.relabelFlip' (Fragment.glueListEqEquiv X (lhs_pairs_eq s t u v ((assocPairs_wf s t u v).append_sep)) @@ -733,7 +773,7 @@ noncomputable def assocNormalLeft {s t u v : ℕ} List.Perm.refl _)).symm).trans (Fragment.Equiv.relabelTrans _ _ _)) -- E4: the glued left factor is the embedded fold, relabelled. - have E4 : (N₁.disjUnion H).Equiv (X.relabel i) := + have E4 := (Fragment.Equiv.relabelFlip (Fragment.glueListDisjUnionLeft (F.disjUnion G) H (interfacePairs s t u) @@ -766,8 +806,7 @@ noncomputable def assocNormalLeft {s t u v : ℕ} List.Perm.refl _)).symm).trans (Fragment.Equiv.relabelTrans _ _ _)) -- E1: normalize the inner composition inside the disjoint union. - have E1 : ((F.compose G).disjUnion H).Equiv - ((N₁.disjUnion H).relabel σ) := + have E1 := (Fragment.Equiv.disjUnionCongr (composeNormal F G) (Fragment.Equiv.refl H)).trans (Fragment.relabelDisjUnionLeft N₁ H @@ -797,6 +836,10 @@ noncomputable def rhsQs1 (s t u v : ℕ) : ((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 : ℕ) := @@ -866,6 +909,10 @@ noncomputable def rhsLabelEquiv (s t u v : ℕ) : ((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. -/ @@ -888,11 +935,11 @@ noncomputable def assocNormalRight {s 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) := - Fragment.mapPairs_wf σ'.symm _ (interfacePairs_wf s t v) + 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) := - Fragment.mapPairs_wf (rhsBridgeEquiv s t u v).symm _ wfqs2 + 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' := @@ -911,19 +958,7 @@ noncomputable def assocNormalRight {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 : YR.Equiv - ((Fragment.glueList A - (Fragment.inlPairs (interfacePairs s t u) ++ - uPairsAssoc s t u v) - (assocPairs_wf s t u v)).relabel - ((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)) := + have CP := (Fragment.glueListPerm A (List.perm_append_comm (l₁ := uPairsAssoc s t u v) @@ -948,25 +983,7 @@ noncomputable def assocNormalRight {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.glueList UPA (rhsQs3 s t u v) wfqs3).Equiv - ((Fragment.glueList A - (Fragment.inlPairs (interfacePairs s t u) ++ - uPairsAssoc s t u v) - (assocPairs_wf s t u v)).relabel - (((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))) := + have CR8 := (Fragment.Equiv.relabelFlip' (Fragment.glueListEqEquiv UPA (rhs_pairs_eq s t u v @@ -994,7 +1011,7 @@ noncomputable def assocNormalRight {s t u v : ℕ} (Fragment.Equiv.relabelTrans _ _ _)) -- ═══════ STAGE 2: THE ASSOCIATIVITY BRIDGE ═══════ -- CRX: the associativity bridge on the inner fold. - have CRX : XR.Equiv (UPA.relabel (rhsBridgeEquiv s t u v)) := + have CRX := (Fragment.glueListCongr (Fragment.Equiv.relabelFlip (Fragment.disjUnionAssoc F G H)) _ _).trans @@ -1027,14 +1044,7 @@ noncomputable def assocNormalRight {s t u v : ℕ} List.Perm.refl _)).symm).trans (Fragment.Equiv.relabelTrans _ _ _))) -- CR5: transport the outer pairs across the bridge. - have CR5 : (Fragment.glueList XR (rhsQs2 s t u v) wfqs2).Equiv - ((Fragment.glueList UPA (rhsQs3 s t u v) wfqs3).relabel - ((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)) := + have CR5 := (Fragment.glueListCongr CRX _ _).trans ((Fragment.Equiv.relabelFlip' (Fragment.glueListEqEquiv @@ -1056,20 +1066,14 @@ noncomputable def assocNormalRight {s t u v : ℕ} (Fragment.Equiv.relabelTrans _ _ _))) -- ═══════ STAGE 3: THE EMBEDDED FOLD ═══════ -- ER4: the inner composition is the embedded fold. - have ER4 : (F.disjUnion N₂).Equiv (XR.relabel i') := + 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.glueList (F.disjUnion N₂) - (rhsQs1 s t u v) wfqs1).Equiv - ((Fragment.glueList XR (rhsQs2 s t u v) wfqs2).relabel - ((Fragment.foldSurvivingMapEquiv i' (rhsQs2 s t u v)).trans - (Fragment.foldSurvivingPermEquiv - ((mapPairs_symm_cancel i' (rhsQs1 s t u v)).symm ▸ - List.Perm.refl _)).symm)) := + have CR3 := (Fragment.glueListCongr ER4 _ _).trans ((Fragment.Equiv.relabelFlip' (Fragment.glueListEqEquiv (XR.relabel i') @@ -1086,22 +1090,13 @@ noncomputable def assocNormalRight {s t u v : ℕ} (Fragment.Equiv.relabelTrans _ _ _))) -- ═══════ STAGE 4: THE INNER COMPOSITION, NORMALIZED ═══════ -- ER1: normalize the inner composition. - have ER1 : (F.disjUnion (G.compose H)).Equiv - ((F.disjUnion N₂).relabel σ') := + 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.glueList (F.disjUnion (G.compose H)) - (interfacePairs s t v) (interfacePairs_wf s t v)).Equiv - ((Fragment.glueList (F.disjUnion N₂) - (rhsQs1 s t u v) wfqs1).relabel - ((Fragment.foldSurvivingMapEquiv σ' (rhsQs1 s t u v)).trans - (Fragment.foldSurvivingPermEquiv - ((mapPairs_symm_cancel σ' - (interfacePairs s t v)).symm ▸ - List.Perm.refl _)).symm)) := + have CR1 := (Fragment.glueListCongr ER1 _ _).trans ((Fragment.Equiv.relabelFlip' (Fragment.glueListEqEquiv ((F.disjUnion N₂).relabel σ') @@ -1177,7 +1172,7 @@ theorem label_equiv_meet (s t u v : ℕ) : exact (hxp _ hmem).2 (congrArg Sum.inr (Fin.ext (rfl : b.val = b.val))) · exact Fin.ext - (by show s + (b.val - u) = s + (t + (b.val - u) - t); omega) + (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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeNormal.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeNormal.lean index db976d683e..52b47bf407 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeNormal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeNormal.lean @@ -68,7 +68,7 @@ theorem interfacePairs_wf (s t u : ℕ) : 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 - show a.val < s + change a.val < s exact a.isLt⟩ left_inv a := Subtype.ext (Fin.ext rfl) right_inv a := Fin.ext rfl @@ -80,14 +80,14 @@ def finGeEquiv (t u : ℕ) : {b : Fin (t + u) // ¬ b.val < t} ≃ Fin u where have h2 := Nat.le_of_not_lt b.prop omega⟩ invFun b := ⟨⟨t + b.val, by have := b.isLt; omega⟩, by - show ¬ t + b.val < t + change ¬ t + b.val < t omega⟩ left_inv b := Subtype.ext (Fin.ext (by have := Nat.le_of_not_lt b.prop - show t + (b.val.val - t) = b.val.val + change t + (b.val.val - t) = b.val.val omega)) right_inv b := Fin.ext (by - show t + b.val - t = b.val + change t + b.val - t = b.val omega) /-- The survival predicate of the interface gluing. -/ @@ -195,8 +195,8 @@ theorem interfaceStepEquiv_inl (s t u : ℕ) (a : Fin (s + t + 1)) ⟨a, fun he => h.1 (congrArg Sum.inl he)⟩) from rfl] refine congrArg Sum.inl (Fin.ext ?_) rw [finRemoveEquiv_val] - show (if a.val < s + t then a.val else a.val - 1) = a.val - rw [if_pos ha] + 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. -/ @@ -220,8 +220,8 @@ theorem interfaceStepEquiv_inr_below (s t u : ℕ) (b : Fin (t + 1 + u)) refine congrArg Sum.inr (Fin.ext ?_) unfold rightRemoveEquiv rw [Equiv.trans_apply, finRemoveEquiv_val] - show (if b.val < t then b.val else b.val - 1) = b.val - rw [if_pos hb] + 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. -/ @@ -245,8 +245,8 @@ theorem interfaceStepEquiv_inr_above (s t u : ℕ) (b : Fin (t + 1 + u)) refine congrArg Sum.inr (Fin.ext ?_) unfold rightRemoveEquiv rw [Equiv.trans_apply, finRemoveEquiv_val] - show (if b.val < t then b.val else b.val - 1) = b.val - 1 - rw [if_neg (by omega)] + 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 -/ @@ -261,7 +261,7 @@ theorem interfaceStepEquiv_symm_inl (s t u : ℕ) (k : ℕ) (hk : k < t) : 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 show s + k < s + t; omega)).symm + (by change s + k < s + t; omega)).symm /-- The step re-indexing pulls tail-pair right components back to themselves. -/ @@ -367,7 +367,7 @@ noncomputable def glueInterfaceNormal (s u : ℕ) : (interfacePairs_wf s t u)).relabel (interfaceSurvEquiv s t u)) -- ═══════ t = 0: NOTHING TO GLUE ═══════ | 0, W => by - show (W.relabel (Equiv.sumCongr (finCongr (by omega)) + 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) = @@ -384,7 +384,7 @@ noncomputable def glueInterfaceNormal (s u : ℕ) : exact heq ▸ Fragment.Equiv.refl _ -- ═══════ t + 1: GLUE THE TOP PAIR, RECURSE ═══════ | t + 1, W => by - show (glueInterface s t u + 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 _ @@ -449,7 +449,7 @@ noncomputable def glueInterfaceNormal (s u : ℕ) : refine absurd (Subtype.ext ?_ : x.val = r.1) (x.prop r hr).1 rw [hr1, hval] exact congrArg Sum.inl (Fin.ext - (by show a.val = s + (a.val - s); omega)) + (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⟩ := @@ -502,7 +502,7 @@ noncomputable def glueInterfaceNormal (s u : ℕ) : (Fragment.coercePairsList _ _ (tailPairs s t u) hwf_cons.sep)) x)) ⟨b.val - 1, by have := b.isLt; omega⟩ hstep - (by show t ≤ b.val - 1; omega) + (by change t ≤ b.val - 1; omega) have hR := interfaceSurvEquiv_inr s (t + 1) u ((Fragment.foldSurvivingPermEquiv (by rw [interfacePairs_succ s t u] : @@ -512,7 +512,7 @@ noncomputable def glueInterfaceNormal (s u : ℕ) : b hval (by omega) refine hL.trans (Eq.trans ?_ hR.symm) exact congrArg Sum.inr (Fin.ext (by - show b.val - 1 - t = b.val - (t + 1) + change b.val - 1 - t = b.val - (t + 1) omega)) rw [heqF] refine Fragment.Equiv.trans @@ -546,7 +546,7 @@ noncomputable def composeNormal {s t u : ℕ} (interfacePairs_wf s t u)).relabel ((interfaceSurvEquiv s t u).trans finSumFinEquiv)) := by refine Fragment.Equiv.trans ?_ (Fragment.Equiv.relabelTrans _ _ _) - show ((glueInterface s t u (F.disjUnion G)).relabel + change ((glueInterface s t u (F.disjUnion G)).relabel finSumFinEquiv).Equiv _ exact Fragment.Equiv.relabelCongr (glueInterfaceNormal s u t (F.disjUnion G)) finSumFinEquiv diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeRelabel.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeRelabel.lean index 4ac1515de3..3d5f981881 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeRelabel.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeRelabel.lean @@ -47,7 +47,7 @@ theorem outPermEquiv_symm (s : ℕ) {t : ℕ} 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 show x.val = s + (x.val - s); omega), + Fin.ext (by change x.val = s + (x.val - s); omega), outPermEquiv_symm_high, outPermEquiv_high] private theorem out_ground_aux (s t u : ℕ) @@ -69,7 +69,7 @@ private theorem out_ground_aux (s t u : ℕ) simp only [List.map_cons, Fragment.mapPairs, Prod.map] refine congrArg₂ List.cons (Prod.ext rfl ?_) (out_ground_aux s t u σ l) - show Sum.inr ((outPermEquiv t σ).symm + 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)) = @@ -120,7 +120,7 @@ theorem out_label_meet (s t u : ℕ) (σ : Equiv.Perm (Fin u)) : have hpred := (interfaceSurv_iff s t u xv).mp ((forall_ne_iff_not_mem_flat _ xv).mp hx) rcases xv with a | b - · show finSumFinEquiv (interfaceSurvEquiv s t u + · change finSumFinEquiv (interfaceSurvEquiv s t u ⟨Sum.inl a, hx⟩) = outPermEquiv s σ (finSumFinEquiv (interfaceSurvEquiv s t u ⟨Sum.inl a, hx⟩)) @@ -129,7 +129,7 @@ theorem out_label_meet (s t u : ℕ) (σ : Equiv.Perm (Fin u)) : · 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 show b.val = t + (b.val - t); omega) + 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] @@ -141,25 +141,25 @@ theorem out_label_meet (s t u : ℕ) (σ : Equiv.Perm (Fin u)) : Fin (s + t) ⊕ Fin (t + u)) ≠ p.2 := (forall_ne_iff_not_mem_flat _ _).mpr ((interfaceSurv_iff s t u _).mpr - (by show ¬ (outPermEquiv t σ b).val < t + (by change ¬ (outPermEquiv t σ b).val < t rw [hbv] - show ¬ t + (σ ⟨b.val - t, hj⟩).val < t + change ¬ t + (σ ⟨b.val - t, hj⟩).val < t omega)) - show finSumFinEquiv (interfaceSurvEquiv s t u + 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]; show t ≤ t + _; omega), + (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 ?_ - show (outPermEquiv t σ b).val - t = (σ ⟨b.val - t, hj⟩).val + change (outPermEquiv t σ b).val - t = (σ ⟨b.val - t, hj⟩).val rw [hbv] - show t + (σ ⟨b.val - t, hj⟩).val - t = (σ ⟨b.val - t, hj⟩).val + change t + (σ ⟨b.val - t, hj⟩).val - t = (σ ⟨b.val - t, hj⟩).val omega /-- **Outgoing relabels pass through composition**: permuting the diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/Composition.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/Composition.lean index adfed76361..55c9b73c28 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/Composition.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/Composition.lean @@ -36,12 +36,12 @@ private theorem succAbove_val_ite {n : ℕ} (a : Fin (n + 1)) (y : Fin n) : by_cases hc : Fin.castSucc y < a · rw [Fin.succAbove_of_castSucc_lt _ _ hc] have h1 : (y : ℕ) < (a : ℕ) := hc - rw [if_pos h1] + 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 [if_neg (not_lt.mpr h1)] + rw [ite_eq_right (not_lt.mpr h1)] rfl /-- Inverting that shift: a label above the removed point drops by @@ -51,11 +51,11 @@ private theorem removed_val_ite {n : ℕ} {a : Fin (n + 1)} {y : Fin n} (y : ℕ) = if v < (a : ℕ) then v else v - 1 := by rw [succAbove_val_ite] at h by_cases hc : (y : ℕ) < (a : ℕ) - · rw [if_pos hc] at h - rw [if_pos (by omega)] + · rw [ite_eq_left hc] at h + rw [ite_eq_left (by omega)] omega - · rw [if_neg hc] at h - rw [if_neg (by omega)] + · rw [ite_eq_right hc] at h + rw [ite_eq_right (by omega)] omega /-- `Fin.succAbove` at the removed point inverts `finRemoveEquiv`. -/ @@ -80,7 +80,7 @@ theorem finRemoveEquiv_top_val {n : ℕ} 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, if_pos (by omega)] + rw [h, ha, ite_eq_left (by omega)] /-- `Fin.succAbove` at `t` inverts `rightRemoveEquiv`. -/ theorem rightRemoveEquiv_apply_val (t u : ℕ) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseAssembly.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseAssembly.lean index 3b0c8ff2f3..d19e0ea8fe 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseAssembly.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseAssembly.lean @@ -23,8 +23,7 @@ namespace RS namespace EdgeSubset -open Fragment Classical - +open Fragment /-- The lexicographic order on the interface's label type. -/ @[reducible] local instance assemblyBaseOrder (n : ℕ) : LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := @@ -113,7 +112,7 @@ theorem tensorTermAt_pos {α : Type} [LinearOrder α] [Fintype α] = (EdgeSubset.mk s hc).tFull h (Classical.choice hne).1 (Classical.choice hne).2.val x := by unfold tensorTermAt - rw [dif_pos hc, dif_pos hE, dif_pos hne] + 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 @@ -329,7 +328,7 @@ theorem edgeSum_closeBase_eq_pairAgreeValue {k ℓ : ℕ} refine (relabel_genBoundarySubsetMatches_iff (finCongr (by omega : t = t + 0)) (rightSub B).flags (fun b => diagOf t x (Sum.inr b))).mpr ?_ - show genBoundarySubsetMatches G (rightSub B).flags + change genBoundarySubsetMatches G (rightSub B).flags (fun b => diagOf t x (Sum.inr (finCongr (by omega : t = t + 0) b))) rw [diagOf_inr_relabel] @@ -382,7 +381,7 @@ theorem stepData_sub_flags_closed (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 dif_pos hcl)) ?_ + (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) _ @@ -401,7 +400,7 @@ theorem stepData_sub_flags_open (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 dif_neg hop)) ?_ + (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) _ @@ -419,28 +418,28 @@ theorem carried_eq_glueCount : ∀ (n : ℕ) 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, dif_pos hcl, stepBit] + 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 [if_pos hm] - exact congrArg₂ (· + ·) (if_pos hb).symm hstep + 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 [if_neg hm] - exact congrArg₂ (· + ·) (if_neg hb).symm hstep + 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, dif_neg hcl, stepBit] + 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₂ (· + ·) (if_neg hb).symm rfl)) + (congrArg₂ (· + ·) (ite_eq_right hb).symm rfl)) open Classical in /-- **The colouring side's image subset is the ledger's.** Both are @@ -526,7 +525,7 @@ theorem swapPaired_joinParts (t : ℕ) (F G : Fragment (Fin t)) · intro hx refine boundaryFlag_mem_boundaryFlags ?_ refine inr_mem_joinParts.mpr ?_ - show G.boundaryFlag ((finCongr (by omega : t = t + 0)).symm + change G.boundaryFlag ((finCongr (by omega : t = t + 0)).symm (stepIdent t a)) ∈ s₂ rw [hidx] exact (hused _).mp (inl_mem_joinParts.mp @@ -534,7 +533,7 @@ theorem swapPaired_joinParts (t : ℕ) (F G : Fragment (Fin t)) · intro hx refine boundaryFlag_mem_boundaryFlags ?_ refine inl_mem_joinParts.mpr ?_ - show F.boundaryFlag ((finCongr (by omega : t = 0 + t)).symm a) + change F.boundaryFlag ((finCongr (by omega : t = 0 + t)).symm a) ∈ s₁ refine (hused _).mpr ?_ rw [← hidx] @@ -615,9 +614,8 @@ 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} [LinearOrder γ] - [LinearOrder δ] [Fintype γ] [Fintype δ] - [LinearOrder (γ ⊕ δ)] {W₁ : Fragment γ} {W₂ : Fragment δ} +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 @@ -845,7 +843,7 @@ theorem usedLabLeftCloseJoin_val {t : ℕ} {F G : Fragment (Fin t)} (a : UsedLab (leftSub (EdgeSubset.mk (closeJoin s₁ s₂) hc))) : (usedLabLeftCloseJoin hc hc₁ a).val = (leftIso t).symm a.val := by - show (leftIso t).symm + change (leftIso t).symm (usedLabOrderIsoOfEq (leftSub_closeJoin hc hc₁) a).val = _ rw [usedLabOrderIsoOfEq_val] @@ -859,7 +857,7 @@ theorem usedLabRightCloseJoin_val {t : ℕ} {F G : Fragment (Fin t)} (b : UsedLab (rightSub (EdgeSubset.mk (closeJoin s₁ s₂) hc))) : (usedLabRightCloseJoin hc hc₂ b).val = (rightIso t).symm b.val := by - show (rightIso t).symm + change (rightIso t).symm (usedLabOrderIsoOfEq (rightSub_closeJoin hc hc₂) b).val = _ rw [usedLabOrderIsoOfEq_val] @@ -914,7 +912,7 @@ theorem edge_val_map_left {t : ℕ} {F G : Fragment (Fin t)} = chordInv (leftSub (EdgeSubset.mk (closeJoin s₁ s₂) hc)) (pairRelLeft hc₁ hc (relabelTransUp (leftIso t).toEquiv (EdgeSubset.mk s₁ hc₁) κ₁)) a.val := by - show ((usedLabLeftCloseJoin (s₂ := s₂) hc hc₁).symm + 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] @@ -938,7 +936,7 @@ theorem edge_val_map_right {t : ℕ} {F G : Fragment (Fin t)} = chordInv (rightSub (EdgeSubset.mk (closeJoin s₁ s₂) hc)) (pairRelRight hc₂ hc (relabelTransUp (rightIso t).toEquiv (EdgeSubset.mk s₂ hc₂) κ₂)) b.val := by - show ((usedLabRightCloseJoin (s₁ := s₁) hc hc₂).symm + 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] @@ -968,7 +966,7 @@ theorem usedLabRight_interfaceSideDisj {t : ℕ} (usedLabLeftCloseJoin (s₂ := s₂) hc hc₁ a) := by refine Subtype.ext ?_ rw [usedLabRightCloseJoin_val] - show (rightIso t).symm + change (rightIso t).symm ((interfaceSideDisjEquiv (EdgeSubset.mk (closeJoin s₁ s₂) hc) (stepIdentOrderIso t).toEquiv hp a).val) = ((usedLabLeftCloseJoin (s₂ := s₂) hc hc₁) a).val @@ -1085,7 +1083,7 @@ theorem sign_composition_pair {t : ℕ} {F G : Fragment (Fin t)} (edge_eq_cutMatching _ _ _ _ (edge_val_map_right hc hc₂ κ₂ M₂ hM₂)) (fun a => by - show M₂.tail (eR _) = !M₁.tail (eL a) + change M₂.tail (eR _) = !M₁.tail (eL a) exact Eq.trans (congrArg M₂.tail (usedLabRight_interfaceSideDisj hc hc₁ hc₂ _ hb a)) (halt (eL a))) @@ -1229,27 +1227,27 @@ noncomputable def orientReplace {α : Type} (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 [if_pos (κ.match_mem f hf), if_pos hf] + 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 [if_pos hp, if_pos hf] + 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} [LinearOrder α] +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 := if_pos hf + (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} - [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} + {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 := if_neg hf + (orientReplace o g).isOut f = g f := ite_eq_right hf /-! ## The colouring sum sees only the internal directions @@ -1393,7 +1391,7 @@ theorem throughMixedPartitionC_eq_edgeTermAt_canon · 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 [dif_pos hc, dif_pos hbnd, if_pos hE, dif_pos hne, + · 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, @@ -1403,15 +1401,15 @@ theorem throughMixedPartitionC_eq_edgeTermAt_canon hbnd (Classical.choice hne) ⟨(𝒟 s hc hE hne).1, ⟨(𝒟 s hc hE hne).2, hcanon s hc hE hne⟩⟩ - · rw [dif_pos hc, dif_pos hbnd, if_pos hE, dif_neg 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 [dif_pos hc, dif_pos hbnd, if_neg hE, + · 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 [dif_pos hc, dif_neg hbnd, + · rw [dite_eq_left hc, dite_eq_right hbnd, edgeTermAt_eq_zero_of_not_matches h 𝒟 st hbnd 0, mul_zero] - · rw [dif_neg hc, edgeTermAt_eq_zero_of_not_closed h 𝒟 st hc 0, + · rw [dite_eq_right hc, edgeTermAt_eq_zero_of_not_closed h 𝒟 st hc 0, mul_zero] open Classical in @@ -1462,10 +1460,10 @@ theorem cutMatching_tail_of_not_through [LinearOrder α] {W : Fragment α} (hnt : ¬ IsThroughLabel F i.val) : (cutMatching F κ o).tail i = !chainDir o (W.boundaryFlag i.val) := by - show (if IsThroughLabel F i.val then + change (if IsThroughLabel F i.val then decide (i.val < chordInv F κ i.val) else !chainDir o (W.boundaryFlag i.val)) = _ - rw [if_neg hnt] + rw [ite_eq_right hnt] end TailChain @@ -1742,7 +1740,7 @@ theorem glueDataOpen_pos {α : Type} [LinearOrder α] = RelTransitionSystem.glueOpen hij hopen t hct hcL (𝒟 (liftSubsetOpen hopen t) hcL hEL hneL).1 := by unfold glueDataOpen - rw [dif_pos hag] + rw [dite_eq_left hag] open Classical in /-- **The closing glue's directions.** A closing cut rewires @@ -1794,7 +1792,7 @@ theorem isOut_glueDataOpen_pos {α : Type} [LinearOrder α] = (𝒟 (liftSubsetOpen hopen t) hcL hEL hneL).2.isOut f'.val := by unfold glueDataOpen - rw [dif_pos hag] + rw [dite_eq_left hag] rfl section FamilySubsetCongr @@ -1877,7 +1875,7 @@ theorem match_unglue_glueDataOpen {α : Type} [LinearOrder α] rw [hF] exact hf unfold unglueDataOpen - rw [dif_pos hdc, match_relOfEq, + 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 @@ -1916,7 +1914,7 @@ theorem isOut_unglue_glueDataOpen {α : Type} [LinearOrder α] have hlift : liftSubsetOpen hopen (V.dropSubset i j s) = s := liftSubsetOpen_dropSubset hij hopen s hc unfold unglueDataOpen - rw [dif_pos hdc, isOut_orientOfEq] + 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] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseFamily.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseFamily.lean index 41854bbd2b..75c3263b83 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseFamily.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseFamily.lean @@ -22,8 +22,7 @@ namespace RS namespace EdgeSubset -open Fragment Classical - +open Fragment /-- The lexicographic order on the interface's label type. -/ @[reducible] local instance famBaseOrder (n : ℕ) : LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := @@ -136,7 +135,7 @@ theorem exists_pairDatum_total {k ℓ : ℕ} · rw [show pairAgreeValue (EdgeSubset.mk s₁ hc₁) (EdgeSubset.mk s₂ hc₂) h o₁' o₂' st = 0 by unfold pairAgreeValue - rw [dif_pos hm₁, dif_neg hm₂]] + 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₁] @@ -150,13 +149,13 @@ theorem exists_pairDatum_total {k ℓ : ℕ} · intro f hf cases f with | inl g => - show Sum.inl _ = Sum.inl _ + 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 => - show Sum.inr _ = Sum.inr _ + 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 @@ -642,7 +641,7 @@ theorem cutBalanced_stageSubset (n : ℕ) (gluePair_eq_open n V hop) (V.dropSubset (cutL n) (cutR n) s) := by unfold stageSubset - exact dif_neg hop + 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, @@ -665,7 +664,7 @@ theorem bitsOf_castSucc (n : ℕ) (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 - show (Fin.snoc (bitsOf n (stepFragment n V) (stageSubset n V s)) + 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 @@ -682,7 +681,7 @@ theorem stageSubset_closed (n : ℕ) (gluePair_eq_closed n V hcl) (V.dropSubset (cutL n) (cutR n) s) := by unfold stageSubset - exact dif_pos hcl + exact dite_eq_left hcl /-- The stage subset, at an open cut. -/ theorem stageSubset_open (n : ℕ) @@ -696,7 +695,7 @@ theorem stageSubset_open (n : ℕ) (gluePair_eq_open n V hop) (V.dropSubset (cutL n) (cutR n) s) := by unfold stageSubset - exact dif_neg hop + exact dite_eq_right hop open Classical in /-- **The base's directions give the alignment at every stage.** @@ -1041,7 +1040,7 @@ theorem cutBalanced_stageSubset_closed (n : ℕ) (gluePair_eq_closed n V hcl) (V.dropSubset (cutL n) (cutR n) s) := by unfold stageSubset - exact dif_pos hcl + 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, @@ -1068,7 +1067,7 @@ theorem edgeTermAt_pushData_colourSum {k ℓ : ℕ} * edgeTermAt h 𝒢 emptyState (imageOf n V s) C | 0, V, 𝒢, s, _, _, C => by rw [Fintype.sum_unique] - show edgeTermAt h (relabelDataDown baseIso 𝒢) _ s C + change edgeTermAt h (relabelDataDown baseIso 𝒢) _ s C = (1 : ℂ) * _ rw [one_mul] refine Eq.trans ?_ @@ -1077,7 +1076,7 @@ theorem edgeTermAt_pushData_colourSum {k ℓ : ℕ} (fun st => edgeTermAt h (relabelDataDown baseIso 𝒢) st s C) (funext fun a => isEmptyElim a) | n + 1, V, 𝒢, s, hc, hbal, C => by - show (∑ x : Fin (n + 1) → (Fin k ⊕ Fin (2 * ℓ)), + 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)) = _ @@ -1142,7 +1141,7 @@ theorem edgeTermAt_pushData_colourSum {k ℓ : ℕ} (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, if_neg (by simp : ¬ ((false : Bool) + 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) @@ -1157,7 +1156,7 @@ theorem edgeTermAt_pushData_colourSum {k ℓ : ℕ} (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, if_pos rfl] + 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) _ @@ -1439,7 +1438,7 @@ theorem match_liftData_glueData_bitsOf : ∀ (n : ℕ) 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 - show (liftData n (stepFragment n V) + 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)) 𝒟) @@ -1461,7 +1460,7 @@ theorem match_liftData_glueData_bitsOf : ∀ (n : ℕ) (stepBit n V D) 𝒟 D hcompat (fun hcL hEL hneL => hal'.1 hcl _ hcL hEL hneL (by - show CutBalanced V (liftSubsetOpen + 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] @@ -1518,7 +1517,7 @@ theorem tensorTermAt_eq_zero_of_not_closed {α : Type} [LinearOrder α] (s : Finset V.Flag) (x : GenBoundaryState k ℓ α) (hc : ¬ ∀ f ∈ s, V.pairing f ∈ s) : tensorTermAt V h s x = 0 := by unfold tensorTermAt - rw [dif_neg hc] + rw [dite_eq_right hc] open Classical in /-- **A non-Eulerian subset carries no tensor term.** -/ @@ -1529,7 +1528,7 @@ theorem tensorTermAt_eq_zero_of_not_eulerian {α : Type} (hE : ¬ (EdgeSubset.mk s hc).Eulerian) : tensorTermAt V h s x = 0 := by unfold tensorTermAt - rw [dif_pos hc, dif_neg hE] + rw [dite_eq_left hc, dite_eq_right hE] open Classical in /-- **A subset with no canonical data carries no tensor term.** -/ @@ -1541,7 +1540,7 @@ theorem tensorTermAt_eq_zero_of_not_canon {α : Type} [LinearOrder α] (hne : ¬ Nonempty (EdgeSubset.mk s hc).CanonData) : tensorTermAt V h s x = 0 := by unfold tensorTermAt - rw [dif_pos hc, dif_pos hE, dif_neg hne] + rw [dite_eq_left hc, dite_eq_left hE, dite_eq_right hne] open Classical in /-- **Tensors of subsets using different labels are orthogonal.** -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseGram.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseGram.lean index 947cb08327..3d69dae27a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseGram.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseGram.lean @@ -23,7 +23,7 @@ the converse it gives is `regts_sevenster_converse` in namespace RS -open Classical + /-- **THE CONVERSE FROM A SUPER-GRAM FACTORIZATION**: a state-indexed factorization of the connection pairing through the diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseIdentity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseIdentity.lean index 0a2bb5fff9..4176628f04 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseIdentity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseIdentity.lean @@ -21,7 +21,7 @@ sum is `EdgeSubset.base_sum_eq_superForm_pairing_bitsOf`. namespace RS -open scoped Classical + namespace EdgeSubset @@ -111,7 +111,7 @@ tensors. -/ theorem superGramIdentity_of_baseSum (H : BaseSumIsClosure) : SuperGramIdentity := by intro k ℓ h t F G - show mixedPartition h (pairClose 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 _ => ?_) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseLift.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseLift.lean index c7c37b76da..6533d0eb3f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseLift.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseLift.lean @@ -20,8 +20,7 @@ namespace RS namespace EdgeSubset -open Fragment Classical - +open Fragment /-- The lexicographic order on the interface's label type. -/ @[reducible] local instance liftBaseOrder (n : ℕ) : LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := @@ -60,7 +59,7 @@ theorem stepData_roundTrip_open (n : ℕ) = unglueDataOpen (cutL_ne_cutR n) hop (glueDataOpen (cutL_ne_cutR n) hop 𝒟) := by unfold stepDataDown stepDataUp stepDataGlued - rw [dif_neg hop, dif_neg hop, relabelData_roundTrip, + rw [dite_eq_right hop, dite_eq_right hop, relabelData_roundTrip, dataOfEq_roundTrip] open Classical in @@ -73,7 +72,7 @@ theorem stepData_roundTrip_closed (n : ℕ) = unglueDataClosed (cutL_ne_cutR n) hcl (glueDataClosed hcl b 𝒟) := by unfold stepDataDown stepDataUp stepDataGlued - rw [dif_pos hcl, dif_pos hcl, relabelData_roundTrip, + rw [dite_eq_left hcl, dite_eq_left hcl, relabelData_roundTrip, dataOfEq_roundTrip] /-! ## Ungluing sees the system only through its partners @@ -102,9 +101,9 @@ theorem match_unglueOpen_matchEq {α : Type} [LinearOrder α] κ₂).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 - show unglueMatch κ₁.match_ f = unglueMatch κ₂.match_ f + change unglueMatch κ₁.match_ f = unglueMatch κ₂.match_ f unfold unglueMatch - rw [dif_pos ⟨h1, h2⟩, dif_pos ⟨h1, h2⟩, hm _ hg] + rw [dite_eq_left ⟨h1, h2⟩, dite_eq_left ⟨h1, h2⟩, hm _ hg] open Classical in /-- **Ungluing respects matching equality, at a closing cut.** -/ @@ -127,9 +126,9 @@ theorem match_unglueClosed_matchEq {α : Type} [LinearOrder α] obtain ⟨h1, h2⟩ := internal_surviving i j hf have hg := (mem_internalFlags_glueClosed hclosed b s' hc' hcL (f' := ⟨f, h1, h2⟩)).mpr hf - show unglueMatch κ₁.match_ f = unglueMatch κ₂.match_ f + change unglueMatch κ₁.match_ f = unglueMatch κ₂.match_ f unfold unglueMatch - rw [dif_pos ⟨h1, h2⟩, dif_pos ⟨h1, h2⟩, hm _ hg] + 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` @@ -159,7 +158,7 @@ theorem match_unglueDataOpen_congr_at {α : Type} [LinearOrder α] by_cases hag : ∀ f ∈ V.dropSubset i j s, (V.gluePairOpen i j hij hopen).pairing f ∈ V.dropSubset i j s - · rw [dif_pos hag, dif_pos hag, match_relOfEq, match_relOfEq] + · 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 @@ -169,7 +168,7 @@ theorem match_unglueDataOpen_congr_at {α : Type} [LinearOrder α] = EdgeSubset.mk s hc := EdgeSubset.ext hlift rw [hF] exact hf - · rw [dif_neg hag, dif_neg hag] + · rw [dite_eq_right hag, dite_eq_right hag] open Classical in /-- **One subset is enough**, under a transport. -/ @@ -237,7 +236,7 @@ theorem match_stepDataDown_congr_at_open (n : ℕ) (stepDataDown n V 𝒟₁ s hc hE hne).1.MatchEq (stepDataDown n V 𝒟₂ s hc hE hne).1 := by unfold stepDataDown - rw [dif_neg hop, dif_neg hop] + 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 @@ -309,7 +308,7 @@ theorem match_stepDataDown_congr_at_closed (n : ℕ) (stepDataDown n V 𝒟₁ s hc hE hne).1.MatchEq (stepDataDown n V 𝒟₂ s hc hE hne).1 := by unfold stepDataDown - rw [dif_pos hcl, dif_pos hcl] + 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 @@ -329,7 +328,7 @@ theorem match_pushData_liftData_zero (V : Fragment (Fin (0 + 0) ⊕ Fin (0 + 0)) (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 - show (relabelDataDown baseIso (relabelDataUp baseIso 𝒟) s hc hE + change (relabelDataDown baseIso (relabelDataUp baseIso 𝒟) s hc hE hne).1.MatchEq _ rw [relabelData_roundTrip] exact fun _f _hf => rfl diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConversePair.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConversePair.lean index b0d1483a6b..0b11054c8f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConversePair.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConversePair.lean @@ -23,8 +23,7 @@ namespace RS namespace EdgeSubset -open Fragment Classical - +open Fragment /-- The lexicographic order on the interface's label type. -/ @[reducible] local instance pairBaseOrder (n : ℕ) : LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := @@ -255,7 +254,7 @@ theorem pairTailFun_of_not_used {t : ℕ} {F G : Fragment (Fin t)} ∧ G.boundaryFlag m ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags) : pairTailFun hc₁ hc₂ M₁ M₂ c f = c f := by unfold pairTailFun - rw [dif_neg h, dif_neg h'] + 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') : @@ -295,7 +294,7 @@ theorem pairTailFun_intL {t : ℕ} {F G : Fragment (Fin t)} ∧ F.boundaryFlag m' ∈ (EdgeSubset.mk s₁ hc₁).boundaryFlags := ⟨m, rfl, hm⟩ unfold pairTailFun - rw [dif_pos h] + rw [dite_eq_left h] refine congrArg M₁.tail (Subtype.ext ?_) exact (intL_inj ((closeBase F G).boundaryFlag_injective h.choose_spec.1)).symm @@ -328,7 +327,7 @@ theorem pairTailFun_intR {t : ℕ} {F G : Fragment (Fin t)} ∧ G.boundaryFlag m' ∈ (EdgeSubset.mk s₂ hc₂).boundaryFlags := ⟨m, rfl, hm⟩ unfold pairTailFun - rw [dif_neg hno, dif_pos h] + 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 @@ -336,7 +335,7 @@ theorem pairTailFun_intR {t : ℕ} {F G : Fragment (Fin t)} /-- **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} [LinearOrder α] +theorem boundaryFlag_chordInv_of_through {α : Type} {W : Fragment α} (F : EdgeSubset W) (κ : F.RelTransitionSystem) {i : α} (h : W.boundaryFlag i ∈ F.boundaryFlags) (hthr : IsThroughLabel F i) : @@ -467,7 +466,7 @@ theorem flip_pinned_left {t : ℕ} {F G : Fragment (Fin t)} 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] - show O.isOut ((closeBase F G).pairing + change O.isOut ((closeBase F G).pairing ((closeBase F G).boundaryFlag (intL t m))) = _ rw [pairing_boundaryFlag_intL] exact hL _ @@ -489,7 +488,7 @@ theorem flip_pinned_right {t : ℕ} {F G : Fragment (Fin t)} 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] - show O.isOut ((closeBase F G).pairing + change O.isOut ((closeBase F G).pairing ((closeBase F G).boundaryFlag (intR t m))) = _ rw [pairing_boundaryFlag_intR] exact hR _ @@ -546,7 +545,7 @@ 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} [LinearOrder α] [Fintype α] +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) @@ -671,7 +670,7 @@ theorem pairTailFun_cut_unused {t : ℕ} {F G : Fragment (Fin t)} exact hcut m /-- **An absent flag's partner is not internal.** -/ -theorem pairing_not_internal_of_not_mem {α : Type} [LinearOrder α] +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 @@ -1027,7 +1026,7 @@ noncomputable def edgeTermOf {α : Type} open Classical in /-- **The family's summand is its datum's.** -/ theorem edgeTermAt_eq_edgeTermOf {α : Type} [LinearOrder α] - [Fintype α] {V : Fragment α} {k ℓ : ℕ} + {V : Fragment α} {k ℓ : ℕ} (h : MixedFunctional k ℓ) (𝒟 : DataFamily V) (st : GenBoundaryState k ℓ α) {s : Finset V.Flag} (hc : ∀ f ∈ s, V.pairing f ∈ s) @@ -1042,7 +1041,7 @@ theorem edgeTermAt_eq_edgeTermOf {α : Type} [LinearOrder α] open Classical in /-- **The datum's summand transports along an equality of subsets.** -/ -theorem edgeTermOf_ofEq {α : Type} [LinearOrder α] {V : Fragment α} +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'} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseTrip.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseTrip.lean index 8696e8d69a..a85611cd27 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseTrip.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseTrip.lean @@ -18,8 +18,7 @@ namespace RS namespace EdgeSubset -open Fragment Classical - +open Fragment /-- The lexicographic order on the interface's label type. -/ @[reducible] local instance tripBaseOrder (n : ℕ) : LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := @@ -162,11 +161,11 @@ theorem isOut_unglueDataOpen_congr_at {α : Type} [LinearOrder α] by_cases hag : ∀ f ∈ V.dropSubset i j s, (V.gluePairOpen i j hij hopen).pairing f ∈ V.dropSubset i j s - · rw [dif_pos hag, dif_pos hag, isOut_orientOfEq, isOut_orientOfEq] + · 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 [dif_neg hag, dif_neg hag] + · rw [dite_eq_right hag, dite_eq_right hag] open Classical in /-- **One subset is enough for the directions**, at a closing @@ -274,7 +273,7 @@ theorem isOut_stepDataDown_congr_at_open (n : ℕ) (stepDataDown n V 𝒟₁ s hc hE hne).2.isOut f = (stepDataDown n V 𝒟₂ s hc hE hne).2.isOut f := by unfold stepDataDown - rw [dif_neg hop, dif_neg hop] + 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 @@ -310,7 +309,7 @@ theorem isOut_stepDataDown_congr_at_closed (n : ℕ) (stepDataDown n V 𝒟₁ s hc hE hne).2.isOut f = (stepDataDown n V 𝒟₂ s hc hE hne).2.isOut f := by unfold stepDataDown - rw [dif_pos hcl, dif_pos hcl] + 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 @@ -399,7 +398,7 @@ 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} [LinearOrder α] {W : Fragment α} +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)) @@ -420,7 +419,7 @@ 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} [LinearOrder α] +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)) @@ -440,8 +439,8 @@ theorem glueClosed_matchEq {α : Type} [LinearOrder α] /-- **The upward relabel respects matching equality.** It keeps the partner map and only renames the labels. -/ -theorem relabelTransUp_matchEq {α' β' : Type} [LinearOrder α'] - [LinearOrder β'] (ee : α' ≃ β') {W' : Fragment α'} +theorem relabelTransUp_matchEq {α' β' : Type} + (ee : α' ≃ β') {W' : Fragment α'} (F : EdgeSubset W') {κ₁ κ₂ : F.RelTransitionSystem} (hm : κ₁.MatchEq κ₂) : (relabelTransUp ee F κ₁).MatchEq (relabelTransUp ee F κ₂) := @@ -481,7 +480,7 @@ theorem match_glueDataOpen_stepDataOpen (n : ℕ) (liftSubsetOpen_stepFlags_pairing_mem n V D hop) (relOfEq (sub_eq_liftSubsetOpen n V D hop) D.rel)) := by unfold glueDataOpen - rw [dif_pos (hag _ _ _)] + 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 @@ -606,10 +605,10 @@ theorem match_stepDataUp_stepData_open (n : ℕ) (relabelDataUp (stepIso n) (glueDataOpen (cutL_ne_cutR n) hop 𝒟)) := by unfold stepDataUp - rw [dif_neg hop, relabelDataUp_dataOfEq] + rw [dite_eq_right hop, relabelDataUp_dataOfEq] rfl revert hct hEt hnet - rw [show stepData n V D = _ from dif_neg hop, hup] + 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)) @@ -722,10 +721,10 @@ theorem match_stepDataUp_stepData_closed (n : ℕ) (relabelDataUp (stepIso n) (glueDataClosed hcl (stepBit n V D) 𝒟)) := by unfold stepDataUp - rw [dif_pos hcl, relabelDataUp_dataOfEq] + rw [dite_eq_left hcl, relabelDataUp_dataOfEq] rfl revert hct hEt hnet - rw [show stepData n V D = _ from dif_pos hcl, hup] + 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)) @@ -809,7 +808,7 @@ theorem isOut_stepDataUp_open (n : ℕ) (dataOfEq (gluePair_eq_open n V hop).symm (glueDataOpen (cutL_ne_cutR n) hop 𝒟)) := by unfold stepDataUp - rw [dif_neg hop] + 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) @@ -886,7 +885,7 @@ theorem isOut_stepDataUp_closed (n : ℕ) (dataOfEq (gluePair_eq_closed n V hcl).symm (glueDataClosed hcl b 𝒟)) := by unfold stepDataUp - rw [dif_pos hcl] + 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) @@ -944,7 +943,7 @@ 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} [LinearOrder α] {W : Fragment α} +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) @@ -958,7 +957,7 @@ theorem isOut_rewire_eq {α : Type} [LinearOrder α] {W : Fragment α} = o.isOut (W.pairing (W.boundaryFlag ℓ)) := by by_cases hi : W.pairing (W.boundaryFlag ℓ) = W.boundaryFlag i · rw [Fragment.rewire_eq_partnerSurvJ hopen _ hi] - show o.isOut (W.pairing (W.boundaryFlag j)) = _ + 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)) @@ -966,7 +965,7 @@ theorem isOut_rewire_eq {α : Type} [LinearOrder α] {W : Fragment α} 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] - show o.isOut (W.pairing (W.boundaryFlag i)) = _ + change o.isOut (W.pairing (W.boundaryFlag i)) = _ rw [hj, h3] · rw [Fragment.rewire_val_of_ne hopen _ hi hj] @@ -1409,7 +1408,7 @@ theorem cutExtend_of_ne (n : ℕ) cutExtend n V hop hL1 hR1 hR2 c' f = c' (stageFlag n V hop f h1 h2) := by unfold cutExtend - rw [dif_neg h1, dif_neg h2] + 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 @@ -1429,7 +1428,7 @@ theorem cutExtend_cutL (n : ℕ) = !c' (stageFlag n V hop (V.pairing (V.boundaryFlag (cutL n))) hL1 hop) := by unfold cutExtend - rw [dif_pos rfl] + rw [dite_eq_left rfl] open Classical in /-- At the cut's right flag the extension is the opposite of its @@ -1449,8 +1448,8 @@ theorem cutExtend_cutR (n : ℕ) = !c' (stageFlag n V hop (V.pairing (V.boundaryFlag (cutR n))) hR1 hR2) := by unfold cutExtend - rw [dif_neg (fun hx => cutL_ne_cutR n - (V.boundaryFlag_injective hx).symm), dif_pos rfl] + 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 : ℕ) @@ -1494,7 +1493,7 @@ theorem cutExtendClosed_of_ne (n : ℕ) cutExtendClosed n V hcl c' f = c' (stageFlagClosed n V hcl f h1 h2) := by unfold cutExtendClosed - rw [dif_neg h1, dif_neg h2] + rw [dite_eq_right h1, dite_eq_right h2] open Classical in /-- At the cut's left flag the extension is `true`. -/ @@ -1505,7 +1504,7 @@ theorem cutExtendClosed_cutL (n : ℕ) (c' : (stepFragment n V).Flag → Bool) : cutExtendClosed n V hcl c' (V.boundaryFlag (cutL n)) = true := by unfold cutExtendClosed - rw [dif_pos rfl] + rw [dite_eq_left rfl] open Classical in /-- At the cut's right flag the extension is `false`. -/ @@ -1517,8 +1516,8 @@ theorem cutExtendClosed_cutR (n : ℕ) cutExtendClosed n V hcl c' (V.boundaryFlag (cutR n)) = false := by unfold cutExtendClosed - rw [dif_neg (fun hx => cutL_ne_cutR n - (V.boundaryFlag_injective hx).symm), dif_pos rfl] + 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CrossingDelta.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CrossingDelta.lean index b927f3c352..78191a46d5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CrossingDelta.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CrossingDelta.lean @@ -21,7 +21,7 @@ and the four-end block (evaluated to the mutual-crossing indicator). namespace RS -open scoped Classical + variable {α : Type} @@ -58,17 +58,17 @@ private theorem sorted_pair_sum [LinearOrder α] · 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 [if_pos ⟨huw, hxy, hux, hxw, hwy⟩, if_neg h2, - if_pos ⟨hxy, Or.inr ⟨hux, hxw, hwy⟩⟩] + 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 [if_neg h1, if_pos ⟨hxy, huw, hxu, huy, hyw⟩, - if_pos ⟨hxy, Or.inl ⟨hxu, huy, hyw⟩⟩] + 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 [if_neg h1, if_neg h2, if_neg h3] + rw [ite_eq_right h1, ite_eq_right h2, ite_eq_right h3] /-- The four ordered crossing indicators between one chord with ends labelled `a`, `b` and a chord recorded as `(x, y)` sum to the gated @@ -88,19 +88,19 @@ private theorem side_label_sum [LinearOrder α] 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 := - if_neg (fun hc => lt_asymm h hc.1) + 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 := - if_neg (fun hc => lt_asymm h hc.2.1) + 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 := - if_neg (fun hc => lt_asymm h hc.1) + 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 := - if_neg (fun hc => lt_asymm h hc.2.1) + 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 @@ -247,7 +247,7 @@ private theorem chordCross_self_ite (κ : F.RelTransitionSystem) {x : W.Flag} (hx : x ∈ F.boundaryFlags) : (if ChordCross κ ⟨x, hx⟩ ⟨x, hx⟩ then (1 : ℕ) else 0) = 0 := - if_neg fun h => by + ite_eq_right fun h => by obtain ⟨-, -, hlt, -, -⟩ := (chordCross_iff_labels _ _).mp h exact lt_irrefl _ hlt @@ -259,7 +259,7 @@ private theorem chordCross_partner_ite (hy : y ∈ F.boundaryFlags) (hyx : κ.pathMatch y hy = x) : (if ChordCross κ ⟨x, hx⟩ ⟨y, hy⟩ then (1 : ℕ) else 0) = 0 := by - refine if_neg (fun h => ?_) + 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}))) = @@ -480,25 +480,25 @@ private theorem touched_line_parity (min (F.boundaryLabel h₁) (F.boundaryLabel h₂)) (max (F.boundaryLabel h₁) (F.boundaryLabel h₂))) then (1 : ℕ) else 0) = 0 := - if_neg (fun hc => hxy hc.1) + 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 := - if_neg (fun hc => hxy hc.1) + 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 := - if_neg (fun hc => hxy hc.1) + 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 := - if_neg (fun hc => hxy hc.1) + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean index 0c8790dc63..6480ba54d7 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean @@ -31,7 +31,7 @@ own through-edge product uses. namespace RS -open Classical EdgeSubset +open EdgeSubset variable {α : Type} @@ -94,11 +94,11 @@ noncomputable def cutMatching [LinearOrder α] {W : Fragment α} by_cases ht : IsThroughLabel F i.val · have ht' : IsThroughLabel F (chordInv F κ i.val) := isThroughLabel_chordInv F κ i.prop ht - show (if IsThroughLabel F (chordInv F κ i.val) then + 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 [if_pos ht', if_pos ht, chordInv_invol] + 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 @@ -109,11 +109,11 @@ noncomputable def cutMatching [LinearOrder α] {W : Fragment α} have ht' : ¬ IsThroughLabel F (chordInv F κ i.val) := fun hx => Finset.disjoint_left.mp F.internalFlags_disjoint_boundaryFlags hfar hx - show (if IsThroughLabel F (chordInv F κ i.val) then _ + 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 [if_neg ht', if_neg ht, boundaryFlag_chordInv F κ i.prop, + rw [ite_eq_right ht', ite_eq_right ht, boundaryFlag_chordInv F κ i.prop, chainDir_pathMatch o i.prop hint] /-! ### Undoing the dual basis @@ -144,7 +144,7 @@ theorem chordInv_relabelUp [LinearOrder α] {W : Fragment α} ∈ (F.relabelUp e.toEquiv).boundaryFlags := by rw [hbf, relabelUp_boundaryFlags e F] exact hb - rw [dif_pos hb', dif_pos 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 @@ -160,7 +160,7 @@ theorem chordInv_relabelUp [LinearOrder α] {W : Fragment α} ∈ (F.relabelUp e.toEquiv).boundaryFlags) := by rw [hbf, relabelUp_boundaryFlags e F] exact hb - rw [dif_neg hb', dif_neg hb] + rw [dite_eq_right hb', dite_eq_right hb] exact (e.apply_symm_apply b).symm /-- **The used labels shift through the relabel.** -/ @@ -190,7 +190,7 @@ theorem cutMatching_relabelUp_edge [LinearOrder α] {W : Fragment α} (relabelTransUp e.toEquiv F κ) o').map (usedLabRelabelEquiv e F)).edge a).val) = chordInv F κ a.val := by - show e.symm (chordInv (F.relabelUp e.toEquiv) + 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, @@ -386,7 +386,7 @@ theorem cutMatching_portFlip [LinearOrder α] {W : Fragment α} · rintro (hx | hx) · exact Or.inl (Subtype.ext hx) · exact Or.inr (Subtype.ext (by rw [hx]; exact hchord.symm)) - show (if IsThroughLabel F j.val then + 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₁⟩ @@ -397,25 +397,25 @@ theorem cutMatching_portFlip [LinearOrder α] {W : Fragment α} rintro (hx | hx) · exact (not_isThroughLabel_port h) (hx ▸ hnt) · exact (not_isThroughLabel_port' h) (hx ▸ hnt) - rw [if_pos hnt, if_neg (fun hx => hj (hcond.mp hx))] - show _ = if IsThroughLabel F j.val then + 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 [if_pos hnt] + rw [ite_eq_left hnt] · have htail : (cutMatching F κ o).tail j = !chainDir o (W.boundaryFlag j.val) := by - show (if IsThroughLabel F j.val then + change (if IsThroughLabel F j.val then decide (j.val < chordInv F κ j.val) else _) = _ - rw [if_neg hnt] - rw [if_neg hnt, htail, chainDir_eq, chainDir_eq] + 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 [if_pos (hcond.mpr hj), portFlip_isOut_of_mem o h hmem] + 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 [if_neg (fun hx => hj (hcond.mp hx)), + rw [ite_eq_right (fun hx => hj (hcond.mp hx)), portFlip_isOut_of_notMem o h hnm] open Classical in @@ -472,7 +472,7 @@ theorem untwist_apply_of_mem [LinearOrder α] {W : Fragment α} | Sum.inl a => Sum.inl a | Sum.inr c => Sum.inr (oddPartner ℓ c)) else x i := - dif_pos hb + dite_eq_left hb open Classical in /-- The change of basis is trivial off the used labels. -/ @@ -482,7 +482,7 @@ theorem untwist_apply_of_not_mem [LinearOrder α] {W : Fragment α} (x : GenBoundaryState k ℓ α) {i : α} (hb : W.boundaryFlag i ∉ F.boundaryFlags) : untwist F κ o x i = x i := - dif_neg hb + dite_eq_right hb /-! ### The chain flip's effect on the dual basis @@ -522,7 +522,7 @@ theorem tail_portFlip_of_mem [LinearOrder α] {W : Fragment α} {F : EdgeSubset 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, if_pos] + 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)) @@ -544,7 +544,7 @@ theorem tail_portFlip_of_not_mem 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, if_neg] + DirMatching.reverseArc_tail, ite_eq_right] rintro (hx | hx) · exact hj (Or.inl (congrArg Subtype.val hx)) · refine hj (Or.inr ?_) @@ -572,14 +572,14 @@ theorem untwist_portFlip [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} 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, if_neg (by simp), if_pos rfl] + · rw [ht, Bool.not_true, ite_eq_right (by simp), ite_eq_left rfl] rcases hx : x i with a | c · rfl - · show Sum.inr c + · 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, if_pos rfl, - if_neg (by simp)] + · 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₁ @@ -639,18 +639,18 @@ theorem dualWeight_portFlip_mul have hj : ¬ (i = i₁ ∨ i = i₂) := by rintro (rfl | rfl) <;> exact hi (by simp) by_cases hb : W.boundaryFlag i ∈ F.boundaryFlags - · rw [dif_pos hb, dif_pos hb, + · 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 [if_pos ht] + · rw [ite_eq_left ht] exact dualFactor_sq (x i) - · rw [if_neg ht] + · rw [ite_eq_right ht] norm_num - · rw [dif_neg hb, dif_neg hb] + · 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, - dif_pos hb₁, dif_pos hb₂, dif_pos hb₁, dif_pos hb₂, + 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 <;> @@ -672,8 +672,8 @@ theorem untwist_apply_odd [LinearOrder α] {W : Fragment α} 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 [if_pos ht, if_pos ht] - · rw [if_neg ht, if_neg ht] + · rw [ite_eq_left ht, ite_eq_left ht] + · rw [ite_eq_right ht, ite_eq_right ht] /-! ### Reversing one arc's direction @@ -721,19 +721,19 @@ theorem dualWeightD_reverseArc_mul {W : Fragment α} else 1)) = 1 := by intro i h1 h2 by_cases hb : W.boundaryFlag i ∈ F.boundaryFlags - · rw [dif_pos hb, dif_pos hb, + · 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 if_neg (by + 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 [if_pos ht] + · rw [ite_eq_left ht] exact dualFactor_sq (x i) - · rw [if_neg ht] + · rw [ite_eq_right ht] norm_num - · rw [dif_neg hb, dif_neg hb] + · 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 @@ -752,21 +752,21 @@ theorem dualWeightD_reverseArc_mul {W : Fragment α} have htb : M.tail (M.edge a) = false := by rw [M.tail_flip a, hta] rfl - rw [dif_pos a.prop, dif_pos a.prop, dif_pos (M.edge a).prop, - dif_pos (M.edge a).prop] + 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, if_pos (Or.inl rfl), hta] + 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, if_pos (Or.inr rfl), htb] + 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 [if_neg (by simp), if_pos rfl, if_pos rfl, if_neg (by simp), + rw [ite_eq_right (by simp), ite_eq_left rfl, ite_eq_left rfl, ite_eq_right (by simp), hca, hca'] - show (1 * dualSign ℓ c) * (dualSign ℓ (oddPartner ℓ c) * 1) = -1 + change (1 * dualSign ℓ c) * (dualSign ℓ (oddPartner ℓ c) * 1) = -1 rw [dualSign_oddPartner] have hsq := dualSign_sq ℓ c linear_combination -hsq @@ -781,11 +781,11 @@ theorem untwistD_apply_mem {W : Fragment α} = if tl ⟨i, hb⟩ then Sum.map id (oddPartner ℓ) (x i) else x i := by unfold untwistD - rw [dif_pos hb] + rw [dite_eq_left hb] by_cases ht : tl ⟨i, hb⟩ = true - · rw [if_pos ht, if_pos ht] + · rw [ite_eq_left ht, ite_eq_left ht] rcases x i with a | c <;> rfl - · rw [if_neg ht, if_neg ht] + · rw [ite_eq_right ht, ite_eq_right ht] open Classical in /-- The change of basis away from the used legs. -/ @@ -793,7 +793,7 @@ 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 := dif_neg hb + untwistD F tl x i = x i := dite_eq_right hb open Classical in /-- **Reversing an arc partners the colour at its two legs.** -/ @@ -807,7 +807,7 @@ theorem untwistD_reverseArc {W : Fragment α} Sum.map id (oddPartner ℓ) (Sum.map id (oddPartner ℓ) v) = v := by rintro (b | d) · rfl - · show Sum.inr (oddPartner ℓ (oddPartner ℓ d)) = Sum.inr d + · change Sum.inr (oddPartner ℓ (oddPartner ℓ d)) = Sum.inr d rw [oddPartner_invol] funext i by_cases hi₁ : i = a.val @@ -816,14 +816,14 @@ theorem untwistD_reverseArc {W : Fragment α} show (M.reverseArc a).tail ⟨a.val, a.prop⟩ = !M.tail ⟨a.val, a.prop⟩ from by rw [DirMatching.reverseArc_tail] - exact if_pos (Or.inl (Subtype.ext rfl))] + exact ite_eq_left (Or.inl (Subtype.ext rfl))] by_cases ht : M.tail ⟨a.val, a.prop⟩ = true - · rw [ht, Bool.not_true, if_neg (by simp), if_pos rfl, hinv] + · 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, if_pos rfl, if_neg (by simp)] + 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, @@ -831,21 +831,21 @@ theorem untwistD_reverseArc {W : Fragment α} 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 if_pos (Or.inr (Subtype.ext rfl))] + 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, if_neg (by simp), if_pos rfl, hinv] + · 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, if_pos rfl, if_neg (by simp)] + 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 if_neg (by + exact ite_eq_right (by rintro (hx | hx) · exact hi₁ (congrArg Subtype.val hx) · exact hi₂ (congrArg Subtype.val hx))] @@ -864,13 +864,13 @@ theorem dualWeightD_mul_self {W : Fragment α} rw [← Finset.prod_mul_distrib] refine Finset.prod_eq_one (fun i _ => ?_) by_cases hb : W.boundaryFlag i ∈ F.boundaryFlags - · rw [dif_pos hb] + · rw [dite_eq_left hb] by_cases ht : tl ⟨i, hb⟩ = true - · rw [if_pos ht] + · rw [ite_eq_left ht] exact dualFactor_sq (x i) - · rw [if_neg ht] + · rw [ite_eq_right ht] norm_num - · rw [dif_neg hb] + · rw [dite_eq_right hb] norm_num open Classical in @@ -888,13 +888,13 @@ theorem genBoundarySubsetMatches_untwistD {W : Fragment α} by_cases hb : W.boundaryFlag i ∈ F.boundaryFlags · rw [untwistD_apply_mem F tl x hb] by_cases ht : tl ⟨i, hb⟩ = true - · rw [if_pos ht] + · 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 [if_neg ht] + · rw [ite_eq_right ht] · rw [untwistD_apply_not_mem F tl x hb] constructor · intro hm i @@ -915,13 +915,13 @@ theorem dualWeight_mul_self [LinearOrder α] {W : Fragment α} rw [← Finset.prod_mul_distrib] refine Finset.prod_eq_one (fun i _ => ?_) by_cases hb : W.boundaryFlag i ∈ F.boundaryFlags - · rw [dif_pos hb] + · rw [dite_eq_left hb] by_cases ht : (cutMatching F κ o).tail ⟨i, hb⟩ = true - · rw [if_pos ht] + · rw [ite_eq_left ht] exact dualFactor_sq (x i) - · rw [if_neg ht] + · rw [ite_eq_right ht] norm_num - · rw [dif_neg hb] + · rw [dite_eq_right hb] norm_num /-! ### The through-edge product ignores a chain flip diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CutSubsetSum.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CutSubsetSum.lean index d25e334f53..09a95490ba 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CutSubsetSum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CutSubsetSum.lean @@ -25,7 +25,7 @@ pairing-closed subset is always a lift. namespace RS -open scoped Classical + namespace Fragment @@ -41,7 +41,7 @@ theorem extendPair_left {k ℓ : ℕ} {α : Type} (i j : α) GenBoundaryState.extendPair i j st c c' i = c := by classical unfold GenBoundaryState.extendPair - rw [dif_pos rfl] + rw [dite_eq_left rfl] /-- And at the second, when the two are distinct. -/ theorem extendPair_right {k ℓ : ℕ} {α : Type} {i j : α} @@ -51,7 +51,7 @@ theorem extendPair_right {k ℓ : ℕ} {α : Type} {i j : α} GenBoundaryState.extendPair i j st c c' j = c' := by classical unfold GenBoundaryState.extendPair - rw [dif_neg (Ne.symm hij), dif_pos rfl] + rw [dite_eq_right (Ne.symm hij), dite_eq_left rfl] /-- And the restriction elsewhere. -/ theorem extendPair_surviving {k ℓ : ℕ} {α : Type} (i j : α) @@ -60,7 +60,7 @@ theorem extendPair_surviving {k ℓ : ℕ} {α : Type} (i j : α) GenBoundaryState.extendPair i j st c c' x.val = st x := by classical unfold GenBoundaryState.extendPair - rw [dif_neg x.prop.1, dif_neg x.prop.2] + rw [dite_eq_right x.prop.1, dite_eq_right x.prop.2] /-! ### The closed cut -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DirMatching.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DirMatching.lean index ea5997f84d..d8867ed525 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DirMatching.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DirMatching.lean @@ -77,17 +77,17 @@ 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 [if_pos ha, M.tail_flip a] - · rw [if_neg ha, tail_edge_alt h a] + · 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 [if_pos ha, if_neg (by rw [M.tail_flip a, ha]; simp), + · rw [ite_eq_left ha, ite_eq_right (by rw [M.tail_flip a, ha]; simp), M.edge_invol] - · rw [if_neg ha, if_pos (by rw [tail_edge_alt h a]; simp [ha]), + · rw [ite_eq_right ha, ite_eq_left (by rw [tail_edge_alt h a]; simp [ha]), N.edge_invol] /-- And undoes it. -/ @@ -95,9 +95,9 @@ 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 [if_pos ha, if_neg (by rw [tail_edge_alt h a, ha]; simp), + · rw [ite_eq_left ha, ite_eq_right (by rw [tail_edge_alt h a, ha]; simp), N.edge_invol] - · rw [if_neg ha, if_pos (by rw [M.tail_flip a]; simp [ha]), + · 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. -/ @@ -125,14 +125,14 @@ theorem sameCycle_rot_edge (h : Alternating M N) (a : α) : · exact ⟨1, by show (M.rotPerm N h ^ (1 : ℤ)) a = M.edge a rw [zpow_one] - show M.rot N a = M.edge a - rw [rot, if_pos ha]⟩ + 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] - show (M.rotPerm N h).symm a = M.edge a - show M.rotInv N a = M.edge a - rw [rotInv, if_neg ha]⟩ + 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 : α) : @@ -141,30 +141,30 @@ theorem sameCycle_rot_edge' (h : Alternating M N) (a : α) : · exact ⟨-1, by show (M.rotPerm N h ^ (-1 : ℤ)) a = N.edge a rw [zpow_neg, zpow_one] - show (M.rotPerm N h).symm a = N.edge a - show M.rotInv N a = N.edge a - rw [rotInv, if_pos ha]⟩ + 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] - show M.rot N a = N.edge a - rw [rot, if_neg ha]⟩ + 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 α] [DecidableEq α] (M : DirMatching α) : +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_setOf_eq, + 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_setOf_eq, + simp only [Finset.coe_filter, Set.mem_ofPred_eq, Finset.mem_univ, true_and] at hb ⊢ rw [M.tail_flip b] simpa using hb @@ -187,7 +187,7 @@ noncomputable def tailHeadEquiv (M : DirMatching α) : right_inv a := Subtype.ext (M.edge_invol a.val) /-- **The ground set is twice the tails.** -/ -theorem two_mul_card_tail [Fintype α] [DecidableEq α] +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)} @@ -258,9 +258,9 @@ 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 [if_pos ha, M.edge_invol, - if_neg (by rw [tail_edge_alt h a, ha]; simp), N.edge_invol] - · rw [if_neg ha, if_pos (by rw [tail_edge_alt h a]; simp [ha])] + · 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.** -/ @@ -317,10 +317,10 @@ theorem sign_eq_of_carries_pair [Fintype α] [DecidableEq α] have hg : Stab M (σ * τ⁻¹) := by constructor · intro a - show σ (τ.symm (M.edge a)) = M.edge (σ (τ.symm a)) + change σ (τ.symm (M.edge a)) = M.edge (σ (τ.symm a)) rw [hτ.edge_symm a, hσ.edge] · intro a - show M.tail (σ (τ.symm a)) = M.tail a + change M.tail (σ (τ.symm a)) = M.tail a rw [hσ.tail] conv_rhs => rw [← Equiv.apply_symm_apply τ a] rw [hτ.tail] @@ -353,7 +353,7 @@ noncomputable def ofTailEquiv (M N : DirMatching α) 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 [dif_pos h, dif_pos hm] + 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 @@ -362,14 +362,14 @@ noncomputable def ofTailEquiv (M N : DirMatching α) (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 [dif_neg h, dif_neg hm', M.edge_invol] + 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 [dif_pos h, dif_pos hn] + 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 @@ -378,13 +378,13 @@ noncomputable def ofTailEquiv (M N : DirMatching α) (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 [dif_neg h, dif_neg hn', N.edge_invol] + 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 [Fintype α] [DecidableEq α] +theorem carries_ofTailEquiv (M N : DirMatching α) (b : N.Tail ≃ M.Tail) : Carries M N (ofTailEquiv M N b) := by constructor @@ -392,38 +392,40 @@ theorem carries_ofTailEquiv [Fintype α] [DecidableEq α] by_cases h : N.tail a = true · have hne : ¬ (N.tail (N.edge a) = true) := by rw [N.tail_flip, h]; simp - show (if h' : N.tail (N.edge a) = true then _ else _) = _ - rw [dif_neg hne] - show M.edge (b ⟨N.edge (N.edge a), _⟩).val + 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 [dif_pos h] + 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 - show (if h' : N.tail (N.edge a) = true then (b ⟨N.edge a, h'⟩).val + change (if h' : N.tail (N.edge a) = true then (b ⟨N.edge a, h'⟩).val else _) = _ - rw [dif_pos hne] - show _ = M.edge (if h' : N.tail a = true then _ + rw [dite_eq_left hne] + change _ = M.edge (if h' : N.tail a = true then _ else M.edge (b ⟨N.edge a, _⟩).val) - rw [dif_neg h, M.edge_invol] + rw [dite_eq_right h, M.edge_invol] · intro a by_cases h : N.tail a = true - · show M.tail (if h' : N.tail a = true then (b ⟨a, h'⟩).val else _) + · change M.tail (if h' : N.tail a = true then (b ⟨a, h'⟩).val else _) = N.tail a - rw [dif_pos h, h] + 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 - show M.tail (if h' : N.tail a = true then _ + change M.tail (if h' : N.tail a = true then _ else M.edge (b ⟨N.edge a, _⟩).val) = N.tail a - rw [dif_neg h, M.tail_flip, (b ⟨N.edge a, hne⟩).prop] + 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 [Fintype α] [DecidableEq α] (M N : DirMatching α) : +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 @@ -448,10 +450,10 @@ theorem Carries.comp {P : DirMatching α} {σ τ : Equiv.Perm α} Carries M P (σ * τ) := by constructor · intro a - show σ (τ (P.edge a)) = M.edge (σ (τ a)) + change σ (τ (P.edge a)) = M.edge (σ (τ a)) rw [hτ.edge a, hσ.edge (τ a)] · intro a - show M.tail (σ (τ a)) = P.tail a + change M.tail (σ (τ a)) = P.tail a rw [hσ.tail (τ a), hτ.tail a] /-- Carriers invert. -/ @@ -461,7 +463,7 @@ theorem Carries.inv {σ : Equiv.Perm α} (hσ : Carries M N σ) : · intro a exact hσ.edge_symm a · intro a - show N.tail (σ.symm a) = M.tail a + change N.tail (σ.symm a) = M.tail a conv_rhs => rw [← Equiv.apply_symm_apply σ a] rw [hσ.tail] @@ -547,11 +549,11 @@ def finStd (m : ℕ) : DirMatching (Fin (2 * m)) where have := i.isLt refine Fin.ext ?_ by_cases h : i.val % 2 = 0 - · simp only [if_pos h, - if_neg (show ¬ ((i.val + 1) % 2 = 0) by omega)] + · simp only [ite_eq_left h, + ite_eq_right (show ¬ ((i.val + 1) % 2 = 0) by omega)] omega - · simp only [if_neg h, - if_pos (show (i.val - 1) % 2 = 0 by 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 @@ -563,15 +565,15 @@ def finStd (m : ℕ) : DirMatching (Fin (2 * m)) where tail_flip i := by have := i.isLt by_cases h : i.val % 2 = 0 - · show decide ((⟨if i.val % 2 = 0 then i.val + 1 else i.val - 1, + · change decide ((⟨if i.val % 2 = 0 then i.val + 1 else i.val - 1, _⟩ : Fin (2 * m)).val % 2 = 0) = _ - simp only [if_pos h] + simp only [ite_eq_left h] rw [decide_eq_false (show ¬ ((i.val + 1) % 2 = 0) by omega), decide_eq_true h] rfl - · show decide ((⟨if i.val % 2 = 0 then i.val + 1 else i.val - 1, + · change decide ((⟨if i.val % 2 = 0 then i.val + 1 else i.val - 1, _⟩ : Fin (2 * m)).val % 2 = 0) = _ - simp only [if_neg h] + simp only [ite_eq_right h] rw [decide_eq_true (show (i.val - 1) % 2 = 0 by omega), decide_eq_false h] rfl @@ -596,12 +598,12 @@ theorem carries_map {β : Type} (e : α ≃ β) {R M : DirMatching α} Carries (R.map e) (M.map e) (e.permCongr σ) := by constructor · intro b - show e (σ (e.symm (e (M.edge (e.symm 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 - show R.tail (e.symm (e (σ (e.symm b)))) = M.tail (e.symm 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) @@ -683,19 +685,19 @@ def reverseArc [DecidableEq α] (M : DirMatching α) (a : α) : tail_flip b := by by_cases h1 : b = a · subst h1 - rw [if_pos (Or.inr rfl), if_pos (Or.inl rfl), M.tail_flip, + 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 [if_pos (Or.inl (M.edge_invol a)), - if_pos (Or.inr rfl), M.tail_flip, Bool.not_not] + 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 [if_neg h3, if_neg (fun hx => hx.elim h1 h2), M.tail_flip] + 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 : α) : @@ -730,24 +732,24 @@ theorem carries_reverseArc [DecidableEq α] {σ : Equiv.Perm α} Carries R (M.reverseArc a) (σ * Equiv.swap a (M.edge a)) := by constructor · intro b - show σ (Equiv.swap a (M.edge a) (M.edge 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 - show R.tail (σ (Equiv.swap a (M.edge a) b)) + change R.tail (σ (Equiv.swap a (M.edge a) b)) = (M.reverseArc a).tail b rw [hσ.tail] - show M.tail (Equiv.swap a (M.edge a) b) + 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, if_pos (Or.inl rfl), M.tail_flip] + 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, if_pos (Or.inr rfl), + 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, - if_neg (fun hx => hx.elim h1 h2)] + ite_eq_right (fun hx => hx.elim h1 h2)] /-- **Reversing an arc flips the sign** — RS21's `sgn(M(ω,κ)) = -sgn(M(ω′,κ′))`. -/ @@ -816,7 +818,7 @@ theorem edge_mem_flipSet [Fintype α] {P P' : DirMatching α} exact (Bool.not_inj h1).symm /-- The disagreement set has an even number of points. -/ -theorem even_card_flipSet [Fintype α] [DecidableEq α] +theorem even_card_flipSet [Fintype α] {P P' : DirMatching α} (he : P'.edge = P.edge) : Even (flipSet P P').card := even_card_of_involution _ P.edge @@ -834,7 +836,7 @@ theorem flipSet_reverseArc [Fintype α] [DecidableEq α] 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 [if_pos hb] + · rw [ite_eq_left hb] have hbmem : b ∈ flipSet P P' := by rcases hb with rfl | rfl · exact ha @@ -842,7 +844,7 @@ theorem flipSet_reverseArc [Fintype α] [DecidableEq α] rw [mem_flipSet] at hbmem exact ⟨fun hx => absurd (bool_eq_not_of_ne hbmem) hx, fun hx => absurd hb hx.2⟩ - · rw [if_neg hb] + · rw [ite_eq_right hb] exact ⟨fun hx => ⟨hx, hb⟩, fun hx => hx.1⟩ /-! ### Repairing a union to Eulerian position @@ -919,21 +921,21 @@ theorem not_sameCycle_edge (M N : DirMatching α) (a : α) : intro i have h1 : M.edge ((p ^ i) a) = (M.edgePerm * p ^ i * M.edgePerm) (M.edge a) := by - show M.edge ((p ^ i) a) + 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] - show (p ^ (-i)) ((p ^ j) a) = (p ^ (j - i)) a + 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 - show N.edge ((p ^ i) a) = N.edge (M.edge (M.edge ((p ^ i) a))) + change N.edge ((p ^ i) a) = N.edge (M.edge (M.edge ((p ^ i) a))) rw [M.edge_invol] rw [h2, hstep i] - show p ((p ^ (j - i)) a) = (p ^ (j - i + 1)) a + 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⟩ @@ -1004,11 +1006,12 @@ theorem sameCycle_of_cycleKey_eq [Fintype α] [DecidableEq α] /-- **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 [Fintype α] [DecidableEq α] +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 @@ -1023,7 +1026,7 @@ theorem exists_alternating_repair [Fintype α] [DecidableEq α] · 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 - show decide (cycleKey p (M.edge 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] @@ -1033,7 +1036,7 @@ theorem exists_alternating_repair [Fintype α] [DecidableEq α] 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] - show N.edge (M.edge (M.edge a)) = N.edge a + 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 @@ -1043,7 +1046,7 @@ theorem exists_alternating_repair [Fintype α] [DecidableEq α] rfl have hNflip : ∀ a, T (N.edge a) = !T a := by intro a - show decide (cycleKey p (N.edge 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] @@ -1098,14 +1101,14 @@ theorem rot_rot_of_interface (h : Alternating M N) {i j : α} 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 [if_neg hx] + 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 [if_pos hx] + unfold rot; rw [ite_eq_left hx] rcases hs with hs | hs · refine Or.inr ?_ have hti : M.tail i = false := by @@ -1114,7 +1117,7 @@ theorem rot_rot_of_interface (h : Alternating M N) {i j : α} exact hf rw [hs] unfold rot - rw [if_neg (by rw [hti]; exact Bool.noConfusion), hN] + 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 @@ -1122,7 +1125,7 @@ theorem rot_rot_of_interface (h : Alternating M N) {i j : α} exact hf rw [hs] unfold rot - rw [if_neg (by rw [htj]; exact Bool.noConfusion), hNj] + 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. -/ @@ -1146,13 +1149,13 @@ theorem contractEdge_ne [DecidableEq α] (M : DirMatching α) {i j : α} M.contractEdge i j x ≠ i ∧ M.contractEdge i j x ≠ j := by unfold contractEdge by_cases h1 : M.edge x = i - · rw [if_pos h1] + · 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 [if_neg h1, if_pos h2] + · rw [ite_eq_right h1, ite_eq_left h2] exact ⟨M.edge_ne i, hopen⟩ - · rw [if_neg h1, if_neg h2] + · rw [ite_eq_right h1, ite_eq_right h2] exact ⟨h1, h2⟩ /-- It is an involution on the survivors. -/ @@ -1162,33 +1165,33 @@ theorem contractEdge_invol [DecidableEq α] (M : DirMatching α) {i j : α} M.contractEdge i j (M.contractEdge i j x) = x := by unfold contractEdge by_cases h1 : M.edge x = i - · rw [if_pos h1, if_neg (by rw [M.edge_invol]; exact Ne.symm hij), - if_pos (by rw [M.edge_invol])] + · 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 [if_neg h1, if_pos h2, if_pos (by rw [M.edge_invol])] + · rw [ite_eq_right h1, ite_eq_left h2, ite_eq_left (by rw [M.edge_invol])] rw [← h2, M.edge_invol] - · rw [if_neg h1, if_neg h2, - if_neg (by rw [M.edge_invol]; exact hx), - if_neg (by rw [M.edge_invol]; exact hx'), 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 [if_pos h1] + · 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 [if_neg h1, if_pos h2] + · rw [ite_eq_right h1, ite_eq_left h2] intro hx refine hij ?_ rw [← hx] at h2 rwa [M.edge_invol] at h2 - · rw [if_neg h1, if_neg 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 @@ -1207,19 +1210,19 @@ def contract [DecidableEq α] (M : DirMatching α) {i j : α} (hij : i ≠ j) (congrArg Subtype.val hx) tail x := M.tail x.val tail_flip x := by - show M.tail (M.contractEdge i j x.val) = !M.tail x.val + change M.tail (M.contractEdge i j x.val) = !M.tail x.val unfold contractEdge by_cases h1 : M.edge x.val = i - · rw [if_pos h1, M.tail_flip j, hdir, Bool.not_not] + · 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 [if_neg h1, if_pos h2, M.tail_flip i] + · 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 [if_neg h1, if_neg h2, M.tail_flip x.val] + · rw [ite_eq_right h1, ite_eq_right h2, M.tail_flip x.val] /-! ### The interface matching after one identification @@ -1279,37 +1282,37 @@ theorem sameCycle_rot_contract [DecidableEq α] {M N : DirMatching α} (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 - show ((M.contract hij hopen + 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 [if_pos (show (M.contract hij hopen + · rw [ite_eq_left (show (M.contract hij hopen (tail_ne_of_alternating h hN)).tail x = true from hx), - if_pos hx] + ite_eq_left hx] rfl - · rw [if_neg (show ¬ ((M.contract hij hopen + · rw [ite_eq_right (show ¬ ((M.contract hij hopen (tail_ne_of_alternating h hN)).tail x = true) from hx), - if_neg hx] + ite_eq_right hx] rfl rw [hval] by_cases hx : M.tail x.val = true - · rw [if_pos hx] + · rw [ite_eq_left hx] unfold contractEdge by_cases h1 : M.edge x.val = i - · rw [if_pos h1] + · 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 [if_neg h1, if_pos h2] + · 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 [if_neg h1, if_neg h2] + · rw [ite_eq_right h1, ite_eq_right h2] exact sameCycle_rot_edge h x.val - · rw [if_neg hx] + · rw [ite_eq_right hx] exact sameCycle_rot_edge' h x.val /-- **The contraction's orbits map to the original's.** -/ @@ -1342,17 +1345,17 @@ theorem rot_contract_val [DecidableEq α] (h : Alternating M N) {i j : α} (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 - show ((M.contract hij hopen + 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 [if_pos (show (M.contract hij hopen + · rw [ite_eq_left (show (M.contract hij hopen (tail_ne_of_alternating h hN)).tail x = true from hx), - if_pos hx] + ite_eq_left hx] rfl - · rw [if_neg (show ¬ ((M.contract hij hopen + · rw [ite_eq_right (show ¬ ((M.contract hij hopen (tail_ne_of_alternating h hN)).tail x = true) from hx), - if_neg hx] + ite_eq_right hx] rfl /-- **A step landing on a survivor is unchanged.** -/ @@ -1366,12 +1369,12 @@ theorem rot_contract_eq_rot [DecidableEq α] (h : Alternating M N) {i j : α} rw [rot_contract_val h hij hN hopen x] unfold rot at hs hs' ⊢ by_cases hx : M.tail x.val = true - · rw [if_pos hx] at hs hs' - rw [if_pos hx, if_pos hx] + · rw [ite_eq_left hx] at hs hs' + rw [ite_eq_left hx, ite_eq_left hx] unfold contractEdge - rw [if_neg hs, if_neg hs'] - · rw [if_neg hx] at hs hs' - rw [if_neg hx, if_neg hx] + 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) @@ -1387,15 +1390,15 @@ theorem rot_contract_eq_rot_three [DecidableEq α] (h : Alternating M N) 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 [if_neg hx] + 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 [if_pos hx] - rw [rot_contract_val h hij hN hopen x, if_pos hx] + 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` @@ -1405,11 +1408,11 @@ theorem rot_contract_eq_rot_three [DecidableEq α] (h : Alternating M N) exact this have htj : M.tail j = true := by rw [hdir, hti]; rfl - rw [if_pos hs, hrot, hs] + rw [ite_eq_left hs, hrot, hs] have h1 : M.rot N i = j := by - unfold rot; rw [if_neg (by rw [hti]; exact Bool.noConfusion), hN] + 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 [if_pos htj] + 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 @@ -1422,12 +1425,12 @@ theorem rot_contract_eq_rot_three [DecidableEq α] (h : Alternating M N) rw [hdir] at htj exact Bool.noConfusion htj · rfl - rw [if_neg (fun hxi => hij (hxi.symm.trans hs)), if_pos hs, + 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 [if_neg (by rw [htj]; exact Bool.noConfusion), hNj] + 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 [if_pos hti] + unfold rot; rw [ite_eq_left hti] rw [h1, h2] /-! ### The converse: the contraction loses no orbits @@ -1457,8 +1460,8 @@ theorem sameCycle_pickSurvivor [DecidableEq α] (h : Alternating M N) have hNj : N.edge j = i := by rw [← hN, N.edge_invol] unfold pickSurvivor by_cases ha : a ≠ i ∧ a ≠ j - · rw [dif_pos ha] - · rw [dif_neg ha] + · 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)⟩ @@ -1473,7 +1476,7 @@ theorem sameCycle_pickSurvivor [DecidableEq α] (h : Alternating M N) /-- **Survivors joined by the original rotation are joined by the contracted one.** -/ -theorem sameCycle_contract_of_sameCycle [Fintype α] [DecidableEq α] +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} @@ -1481,6 +1484,8 @@ theorem sameCycle_contract_of_sameCycle [Fintype α] [DecidableEq α] ((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 @@ -1573,8 +1578,8 @@ noncomputable def orbitsEquivContract [Fintype α] [DecidableEq α] refine Quotient.ind (fun x => ?_) have hpick : M.pickSurvivor hopen x.val = x := by unfold pickSurvivor - rw [dif_pos x.prop] - show Quotient.mk _ (M.pickSurvivor hopen x.val) = Quotient.mk _ x + 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 => ?_) @@ -1611,12 +1616,12 @@ theorem rot_closed {i j : α} constructor · unfold rot by_cases hb : M.tail i = true - · rw [if_pos hb, hM] - · rw [if_neg hb, hN] + · rw [ite_eq_left hb, hM] + · rw [ite_eq_right hb, hN] · unfold rot by_cases hb : M.tail j = true - · rw [if_pos hb, hMj] - · rw [if_neg hb, hNj] + · 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) @@ -1634,9 +1639,9 @@ theorem rot_survivor_closed {i j : α} (hM : M.edge i = j) (congrArg P.edge hx)).trans hPj unfold rot by_cases hb : M.tail x.val = true - · rw [if_pos hb] + · rw [ite_eq_left hb] exact key M hM hMj - · rw [if_neg hb] + · rw [ite_eq_right hb] exact key N hN hNj /-- **The restricted rotation is the rotation restricted.** -/ @@ -1644,19 +1649,19 @@ 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 - show ((M.restrict hM).rot (N.restrict hN) x).val = _ + change ((M.restrict hM).rot (N.restrict hN) x).val = _ unfold rot by_cases hb : M.tail x.val = true - · rw [if_pos (show (M.restrict hM).tail x = true from hb), - if_pos hb] + · rw [ite_eq_left (show (M.restrict hM).tail x = true from hb), + ite_eq_left hb] rfl - · rw [if_neg (show ¬ ((M.restrict hM).tail x = true) from hb), - if_neg hb] + · 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 [DecidableEq α] (h : Alternating M N) +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 @@ -1664,9 +1669,9 @@ theorem rot_surviving_iff [DecidableEq α] (h : Alternating M N) constructor · rintro ⟨h1, h2⟩ refine ⟨fun hx => h2 ?_, fun hx => h1 ?_⟩ - · show M.rot N x = j + · change M.rot N x = j rw [hx]; exact hi - · show M.rot N x = i + · change M.rot N x = i rw [hx]; exact hj · intro hx exact rot_survivor_closed hM hN ⟨x, hx⟩ @@ -1698,7 +1703,7 @@ theorem orbitCount_pair [Fintype α] [DecidableEq α] · refine ⟨1, ?_⟩ rw [zpow_one] refine Subtype.ext ?_ - show M.rot N z.val = i + change M.rot N z.val = i rw [hz] exact hj @@ -1749,9 +1754,9 @@ theorem orbitCount_rotPerm_congr [Fintype α] [DecidableEq α] intro P₁ Q₁ P₂ Q₂ _ k₂ hP hQ a unfold rot by_cases ha : P₁.tail a = true - · rw [if_pos ha, show P₁.edge a = P₂.edge a from by rw [hP]] + · rw [ite_eq_left ha, show P₁.edge a = P₂.edge a from by rw [hP]] exact sameCycle_rot_edge k₂ a - · rw [if_neg ha, show Q₁.edge a = Q₂.edge a from by rw [hQ]] + · 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 @@ -1815,11 +1820,11 @@ theorem orbitCount_map [Fintype α] [DecidableEq α] {β : Type} have hconj : (M.map e).rotPerm (N.map e) h' = e.permCongr (M.rotPerm N h) := by refine Equiv.ext (fun b => ?_) - show (M.map e).rot (N.map e) b = e (M.rot N (e.symm 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 [if_pos hb, if_pos hb] - · rw [if_neg hb, if_neg hb] + · 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 @@ -1846,9 +1851,9 @@ theorem contractEdge_of_closed [DecidableEq α] (M : DirMatching α) (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 [if_neg (fun hc => hx' (((M.edge_invol x).symm.trans + rw [ite_eq_right (fun hc => hx' (((M.edge_invol x).symm.trans (congrArg M.edge hc)).trans hM)), - if_neg (fun hc => hx (((M.edge_invol x).symm.trans + ite_eq_right (fun hc => hx (((M.edge_invol x).symm.trans (congrArg M.edge hc)).trans hMj))] /-! ### The component count of a union @@ -1879,7 +1884,7 @@ 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 - show (letI := Classical.decEq α; orbitCount _) = _ + 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, @@ -2018,9 +2023,9 @@ private def interfaceRepair (e : γ ≃ δ) tail := Sum.elim (fun a => !A₁.tail a) (fun b => !B₁.tail (e.symm b)) tail_flip x := by rcases x with a | b - · show (!B₁.tail (e.symm (e a))) = !(!A₁.tail a) + · change (!B₁.tail (e.symm (e a))) = !(!A₁.tail a) rw [e.symm_apply_apply, h a, Bool.not_not] - · show (!A₁.tail (e.symm b)) = !(!B₁.tail (e.symm b)) + · change (!A₁.tail (e.symm b)) = !(!B₁.tail (e.symm b)) rw [h (e.symm b), Bool.not_not] private theorem alternating_sumRepair (e : γ ≃ δ) @@ -2046,10 +2051,10 @@ private theorem sameCycle_inl (e : γ ≃ δ) 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, if_pos ha]] - show (if A₁.tail a = true then (Sum.inl (A₁.edge a) : γ ⊕ δ) + 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 [if_pos ha] + rw [ite_eq_left ha] · have ha' : A₁.tail a = false := by cases hb : A₁.tail a · rfl @@ -2060,28 +2065,28 @@ private theorem sameCycle_inl (e : γ ≃ δ) refine ⟨3, ?_⟩ have h1 : π (Sum.inl a) = Sum.inr (e a) := by rw [hstep] - show (if A₁.tail a = true then (Sum.inl (A₁.edge a) : γ ⊕ δ) + change (if A₁.tail a = true then (Sum.inl (A₁.edge a) : γ ⊕ δ) else Sum.inr (e a)) = Sum.inr (e a) - rw [if_neg ha] + rw [ite_eq_right ha] have h2 : π (Sum.inr (e a)) = Sum.inr (e (B₁.edge a)) := by rw [hstep] - show (if B₁.tail (e.symm (e a)) = true then + 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, if_pos hb] + 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] - show (if B₁.tail (e.symm (e (B₁.edge a))) = true then + 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, if_neg (by rw [hb2]; exact Bool.noConfusion)] + 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 - show π (π (π (Sum.inl a))) = Sum.inl (B₁.edge a) + change π (π (π (Sum.inl a))) = Sum.inl (B₁.edge a) rw [h1, h2, h3] rw [show ((3 : ℤ)) = ((3 : ℕ) : ℤ) from rfl, zpow_natCast, this, - rot, if_neg ha] + rot, ite_eq_right ha] /-- The two-copy rotation projects to the one-copy one. -/ private theorem sameCycle_proj (e : γ ≃ δ) @@ -2099,17 +2104,17 @@ private theorem sameCycle_proj (e : γ ≃ δ) · by_cases ha : A₁.tail a = true · refine ⟨1, ?_⟩ rw [zpow_one, hstep] - show A₁.rot B₁ a = Sum.elim id (fun b => e.symm b) + 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 [if_pos ha, rot, if_pos ha] + rw [ite_eq_left ha, rot, ite_eq_left ha] rfl · refine ⟨0, ?_⟩ rw [zpow_zero, hstep] - show a = Sum.elim id (fun b => e.symm b) + 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 [if_neg ha] + 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 @@ -2122,19 +2127,19 @@ private theorem sameCycle_proj (e : γ ≃ δ) exact Bool.noConfusion refine ⟨1, ?_⟩ rw [zpow_one, hstep] - show A₁.rot B₁ (e.symm b) = Sum.elim id (fun c => e.symm c) + 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 [if_pos hb, rot, if_neg ha] + rw [ite_eq_left hb, rot, ite_eq_right ha] exact (e.symm_apply_apply _).symm · refine ⟨0, ?_⟩ rw [zpow_zero, hstep] - show e.symm b = Sum.elim id (fun c => e.symm c) + 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 [if_neg hb] + rw [ite_eq_right hb] rfl /-- The two copies of a label lie on a common component. -/ @@ -2155,24 +2160,24 @@ private theorem sameCycle_inl_proj (e : γ ≃ δ) (interfaceRepair e h) (alternating_sumRepair e h)) (Sum.inr b) = Sum.inl (e.symm b) := by rw [hstep] - show (if B₁.tail (e.symm b) = true then + 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 [if_neg (show ¬ (B₁.tail (e.symm b) = true) from by + 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] - show (if A₁.tail (e.symm b) = true then + 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 [if_neg ha, e.apply_symm_apply] + 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 γ] [DecidableEq γ] [Fintype δ] [DecidableEq δ] (e : γ ≃ δ) + [Fintype γ] [Fintype δ] (e : γ ≃ δ) (M₁ : DirMatching γ) (M₂ : DirMatching δ) : unionCount (sumMatching M₁ M₂) (interfaceEquivMatching e) @@ -2186,9 +2191,9 @@ theorem unionCount_sumMatching rcases x with a | b · exact congrArg Sum.inl (congrFun hAe a) · refine congrArg Sum.inr ?_ - show e (B₁.edge (e.symm b)) = M₂.edge b + change e (B₁.edge (e.symm b)) = M₂.edge b rw [congrFun hBe (e.symm b)] - show e (e.symm (M₂.edge (e (e.symm b)))) = M₂.edge 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjSubsetSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjSubsetSplit.lean index 883194412b..2ce56d257b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjSubsetSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjSubsetSplit.lean @@ -20,7 +20,7 @@ namespace RS variable {α β : Type} {W₁ : Fragment α} {W₂ : Fragment β} -open scoped Classical + /-! ## The parts and the join -/ @@ -114,7 +114,7 @@ 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 - show (W₁.attach f).map Sum.inl Sum.inl = Sum.inl (Sum.inl v) ↔ + change (W₁.attach f).map Sum.inl Sum.inl = Sum.inl (Sum.inl v) ↔ W₁.attach f = Sum.inl v constructor · intro h @@ -131,7 +131,7 @@ 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 - show (W₂.attach f).map Sum.inr Sum.inr = Sum.inl (Sum.inr v) ↔ + change (W₂.attach f).map Sum.inr Sum.inr = Sum.inl (Sum.inr v) ↔ W₂.attach f = Sum.inl v constructor · intro h @@ -146,13 +146,13 @@ private theorem attach_inr_eq_inr {f : W₂.Flag} {v : W₂.Vertex} : /-- 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 - show (W₂.attach f).map Sum.inr Sum.inr ≠ Sum.inl (Sum.inl v) + 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 - show (W₁.attach f).map Sum.inl Sum.inl ≠ Sum.inl (Sum.inr v) + 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 -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean index 3b90160fb0..a54f2b429c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean @@ -29,7 +29,7 @@ orbits), and splits the through product and the colouring sums. namespace RS -open scoped Classical + /-! ## Membership characterizations (any fragment) -/ @@ -51,7 +51,7 @@ 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 - show (W₁.attach f).map Sum.inl Sum.inl = Sum.inl (Sum.inl v) ↔ + change (W₁.attach f).map Sum.inl Sum.inl = Sum.inl (Sum.inl v) ↔ W₁.attach f = Sum.inl v constructor · intro h @@ -67,7 +67,7 @@ theorem attach_inl_eq_inl {f : W₁.Flag} {v : W₁.Vertex} : 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 - show (W₂.attach f).map Sum.inr Sum.inr = Sum.inl (Sum.inr v) ↔ + change (W₂.attach f).map Sum.inr Sum.inr = Sum.inl (Sum.inr v) ↔ W₂.attach f = Sum.inl v constructor · intro h @@ -82,13 +82,13 @@ theorem attach_inr_eq_inr {f : W₂.Flag} {v : W₂.Vertex} : /-- 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 - show (W₂.attach f).map Sum.inr Sum.inr ≠ Sum.inl (Sum.inl v) + 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 - show (W₁.attach f).map Sum.inl Sum.inl ≠ Sum.inl (Sum.inr v) + change (W₁.attach f).map Sum.inl Sum.inl ≠ Sum.inl (Sum.inr v) rcases W₁.attach f with w | ℓ <;> simp private theorem attach_inl_vertex_iff {g : W₁.Flag} : @@ -121,7 +121,7 @@ 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 - show (∃ i, (W₁.attach g).map Sum.inl Sum.inl = Sum.inr i) ↔ _ + 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 @@ -135,7 +135,7 @@ 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 - show (∃ i, (W₂.attach g).map Sum.inr Sum.inr = Sum.inr i) ↔ _ + 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 @@ -280,7 +280,7 @@ private theorem even_card_fixedPoints (κ : F.RelTransitionSystem) : revPerm κ x.val ∈ Function.fixedPoints κ.walkPermPeriodic := by intro x have hx : κ.walkPermPeriodic x.val = x.val := x.prop - show κ.walkPermPeriodic (revPerm κ x.val) = revPerm κ x.val + change κ.walkPermPeriodic (revPerm κ x.val) = revPerm κ x.val conv_lhs => rw [← hx] have h := congrArg (fun q => q x.val) (walkPerm_revPerm_walkPerm κ) @@ -289,7 +289,7 @@ private theorem even_card_fixedPoints (κ : F.RelTransitionSystem) : (fun x => ⟨revPerm κ x.val, hfix x⟩) ?_ ?_ · intro x refine Subtype.ext (Subtype.ext ?_) - show W.pairing (W.pairing x.val.val) = x.val.val + 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 @@ -556,10 +556,10 @@ noncomputable def prodRel (κ₁ : (leftSub F).RelTransitionSystem) match_invol f hf := by cases f with | inl g => - show Sum.inl (κ₁.match_ (κ₁.match_ g)) = Sum.inl g + change Sum.inl (κ₁.match_ (κ₁.match_ g)) = Sum.inl g rw [κ₁.match_invol g (inl_mem_internal.mp hf)] | inr g => - show Sum.inr (κ₂.match_ (κ₂.match_ g)) = Sum.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 @@ -599,19 +599,19 @@ noncomputable def prodOrient {κ₁ : (leftSub F).RelTransitionSystem} match_flip f hf := by cases f with | inl g => - show o₁.isOut (κ₁.match_ g) = !o₁.isOut g + change o₁.isOut (κ₁.match_ g) = !o₁.isOut g exact o₁.match_flip g (inl_mem_internal.mp hf) | inr g => - show o₂.isOut (κ₂.match_ g) = !o₂.isOut 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 => - show o₁.isOut (W₁.pairing g) = !o₁.isOut 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 => - show o₂.isOut (W₂.pairing g) = !o₂.isOut 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean index 053e364083..306e046cda 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean @@ -15,7 +15,7 @@ the two components. namespace RS -open scoped Classical + section ColourSplit @@ -358,9 +358,9 @@ private theorem relInFlagsAt_join_perm_inl (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 - letI := (W₁.disjUnion W₂).flagOrder - letI := W₁.flagOrder - letI := Classical.dec + 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 _ _) ?_ @@ -394,9 +394,9 @@ private theorem relInFlagsAt_join_perm_inr (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 - letI := (W₁.disjUnion W₂).flagOrder - letI := W₂.flagOrder - letI := Classical.dec + 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 _ _) ?_ @@ -690,8 +690,8 @@ theorem colouringSum_split {k ℓ : ℕ} (fun a => st (Sum.inl a)) hbnd₁ ψ₁ · by_cases hP₂ : genEvenBoundaryMatch (rightSub F) (fun b => st (Sum.inr b)) hbnd₂ ψ₂ - · rw [if_pos ((genEvenBoundaryMatch_join hbnd hbnd₁ hbnd₂ - ψ₁ ψ₂).mpr ⟨hP₁, hP₂⟩), if_pos hP₁, if_pos hP₂] + · 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 φ₁ _ => ?_ @@ -701,8 +701,8 @@ theorem colouringSum_split {k ℓ : ℕ} (fun a => st (Sum.inl a)) φ₁ · by_cases hQ₂ : (rightSub F).coreOddBoundaryMatch (fun b => st (Sum.inr b)) φ₂ - · rw [if_pos ((coreOddBoundaryMatch_join φ₁ φ₂).mpr - ⟨hQ₁, hQ₂⟩), if_pos hQ₁, if_pos hQ₂] + · 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 _ => ?_ @@ -713,20 +713,20 @@ theorem colouringSum_split {k ℓ : ℕ} rw [coreOddSignAt_join_inr o₁ o₂ φ₁ φ₂ v, evenColoursAt_join_inr ψ₁ ψ₂ v, evalOdd_coreOddListAt_join_inr h _ o₁ o₂ φ₁ φ₂ v] - · rw [if_neg (fun hu => hQ₂ + · rw [ite_eq_right (fun hu => hQ₂ ((coreOddBoundaryMatch_join φ₁ φ₂).mp hu).2), - if_neg hQ₂, mul_zero] - · rw [if_neg (fun hu => hQ₁ + ite_eq_right hQ₂, mul_zero] + · rw [ite_eq_right (fun hu => hQ₁ ((coreOddBoundaryMatch_join φ₁ φ₂).mp hu).1), - if_neg hQ₁, zero_mul] - · rw [if_neg (fun hu => hP₂ + ite_eq_right hQ₁, zero_mul] + · rw [ite_eq_right (fun hu => hP₂ ((genEvenBoundaryMatch_join hbnd hbnd₁ hbnd₂ ψ₁ ψ₂).mp hu).2), - if_neg hP₂, mul_zero] - · rw [if_neg (fun hu => hP₁ + ite_eq_right hP₂, mul_zero] + · rw [ite_eq_right (fun hu => hP₁ ((genEvenBoundaryMatch_join hbnd hbnd₁ hbnd₂ ψ₁ ψ₂).mp hu).1), - if_neg hP₁, zero_mul] + ite_eq_right hP₁, zero_mul] end ColourSplit diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean index 15be75f25c..b0b526f382 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean @@ -14,7 +14,7 @@ Migrating canonical data between a union and its components. namespace RS -open scoped Classical + /-! ## The canonical-value migration @@ -73,7 +73,7 @@ theorem inr_mem_boundary /-- A left boundary flag's chain stays left, so the product system's path matching is the left component's. -/ theorem pathMatch_prodRel_inl - [LinearOrder α] [LinearOrder β] {W₁ : Fragment α} {W₂ : Fragment β} + {W₁ : Fragment α} {W₂ : Fragment β} {F : EdgeSubset (W₁.disjUnion W₂)} (κ₁ : (leftSub F).RelTransitionSystem) (κ₂ : (rightSub F).RelTransitionSystem) @@ -82,7 +82,7 @@ theorem pathMatch_prodRel_inl (hb' : g ∈ (leftSub F).boundaryFlags) : (prodRel (F := F) κ₁ κ₂).pathMatch (Sum.inl g) hb = Sum.inl (κ₁.pathMatch g hb') := by - letI := sumLexLinearOrder α β + let := sumLexLinearOrder α β obtain ⟨k, -, hcont, hpm⟩ := pathMatch_chain_length κ₁ hb' have hterm : W₁.pairing (iterWalk κ₁ g k) ∈ (leftSub F).boundaryFlags := by @@ -108,7 +108,7 @@ theorem pathMatch_prodRel_inl -- needs both component orders even though the statement does not. /-- And likewise on the right. -/ theorem pathMatch_prodRel_inr - [LinearOrder α] [LinearOrder β] {W₁ : Fragment α} {W₂ : Fragment β} + {W₁ : Fragment α} {W₂ : Fragment β} {F : EdgeSubset (W₁.disjUnion W₂)} (κ₁ : (leftSub F).RelTransitionSystem) (κ₂ : (rightSub F).RelTransitionSystem) @@ -117,7 +117,7 @@ theorem pathMatch_prodRel_inr (hb' : g ∈ (rightSub F).boundaryFlags) : (prodRel (F := F) κ₁ κ₂).pathMatch (Sum.inr g) hb = Sum.inr (κ₂.pathMatch g hb') := by - letI := sumLexLinearOrder α β + let := sumLexLinearOrder α β obtain ⟨k, -, hcont, hpm⟩ := pathMatch_chain_length κ₂ hb' have hterm : W₂.pairing (iterWalk κ₂ g k) ∈ (rightSub F).boundaryFlags := by diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean index 0f383ba6dd..5be12fdfd4 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean @@ -26,7 +26,7 @@ across boundary pairings is not needed, there being no boundary. namespace RS -open scoped Classical + /-! ## The closed identification, unconditional -/ @@ -686,9 +686,9 @@ theorem relInFlagsAt_join_perm_inl {κ₁ : (leftSub 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 - letI := (W₁.disjUnion W₂).flagOrder - letI := W₁.flagOrder - letI := Classical.dec + 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 _ _) ?_ @@ -723,9 +723,9 @@ theorem relInFlagsAt_join_perm_inr {κ₁ : (leftSub 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 - letI := (W₁.disjUnion W₂).flagOrder - letI := W₂.flagOrder - letI := Classical.dec + 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 _ _) ?_ @@ -1010,12 +1010,12 @@ variable {α β : Type} /-- The boundary label of a left-summand boundary flag. -/ theorem boundaryLabel_inl {W₁ : Fragment α} {W₂ : Fragment β} {F : EdgeSubset (W₁.disjUnion W₂)} - [LinearOrder (α ⊕ β)] {g : W₁.Flag} + {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 ?_ - show ((W₁.attach g).map Sum.inl Sum.inl) = + change ((W₁.attach g).map Sum.inl Sum.inl) = Sum.inr (Sum.inl ((leftSub F).boundaryLabel hb')) rw [EdgeSubset.attach_boundaryLabel hb'] rfl @@ -1023,12 +1023,12 @@ theorem boundaryLabel_inl /-- The boundary label of a right-summand boundary flag. -/ theorem boundaryLabel_inr {W₁ : Fragment α} {W₂ : Fragment β} {F : EdgeSubset (W₁.disjUnion W₂)} - [LinearOrder (α ⊕ β)] {g : W₂.Flag} + {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 ?_ - show ((W₂.attach g).map Sum.inr Sum.inr) = + change ((W₂.attach g).map Sum.inr Sum.inr) = Sum.inr (Sum.inr ((rightSub F).boundaryLabel hb')) rw [EdgeSubset.attach_boundaryLabel hb'] rfl diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeColouring.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeColouring.lean index 00a3a7fae6..4040e8e324 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeColouring.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeColouring.lean @@ -27,7 +27,7 @@ namespace RS namespace EdgeSubset -open Classical + variable {α : Type} @@ -305,9 +305,9 @@ theorem extendFun_pairing {W : Fragment α} = extendFun hbnd φ' f := by unfold extendFun by_cases hc : f.val ∈ F.coreFlags - · rw [dif_pos hc, dif_pos (F.pairing_mem_coreFlags hc)] + · rw [dite_eq_left hc, dite_eq_left (F.pairing_mem_coreFlags hc)] exact φ'.prop ⟨f.val, hc⟩ - · rw [dif_neg hc, dif_neg (not_coreFlags_pairing F f.prop hc)] + · rw [dite_eq_right hc, dite_eq_right (not_coreFlags_pairing F f.prop hc)] exact hag f.val _ _ open Classical in @@ -329,10 +329,10 @@ theorem CoreOddColouring.core_extend {W : Fragment α} (hag : ThroughAgree F χ hbnd) (φ' : F.CoreOddColouring ℓ) : (CoreOddColouring.extend hbnd hag φ').core = φ' := by refine Subtype.ext (funext fun f => ?_) - show extendFun hbnd φ' ⟨f.val, coreFlags_subset F f.prop⟩ + change extendFun hbnd φ' ⟨f.val, coreFlags_subset F f.prop⟩ = φ'.val f unfold extendFun - rw [dif_pos f.prop] + rw [dite_eq_left f.prop] /-- A matching colouring restricts to a matching core colouring. -/ theorem coreOddBoundaryMatch_core {W : Fragment α} @@ -362,12 +362,12 @@ theorem edgeOddBoundaryMatch_extend {W : Fragment α} edgeOddBoundaryMatch F χ (CoreOddColouring.extend hbnd hag φ') := by intro i c hci hmem - show extendFun hbnd φ' ⟨W.boundaryFlag i, hmem⟩ = c + change extendFun hbnd φ' ⟨W.boundaryFlag i, hmem⟩ = c unfold extendFun by_cases hc : W.boundaryFlag i ∈ F.coreFlags - · rw [dif_pos hc] + · rw [dite_eq_left hc] exact hφ' i c hci hc - · rw [dif_neg 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.lean index b111c7708b..066613b1d1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.lean @@ -30,7 +30,7 @@ namespace RS namespace EdgeSubset -open Classical + variable {α : Type} @@ -63,13 +63,13 @@ theorem edgeSum_eq_vertexSum {W : Fragment α} unfold edgeSum vertexSum refine Finset.sum_congr rfl (fun ψ _ => ?_) by_cases hev : genEvenBoundaryMatch F st hbnd ψ - · rw [if_pos hev, if_pos hev] + · 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 [if_neg hev, if_neg hev] + · 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 α} @@ -83,10 +83,10 @@ theorem edgeSum_eq_zero_of_not_throughAgree {W : Fragment α} unfold edgeSum refine Finset.sum_eq_zero (fun ψ _ => ?_) by_cases hev : genEvenBoundaryMatch F st hbnd ψ - · rw [if_pos hev] - exact Finset.sum_eq_zero (fun φ _ => if_neg (fun hφ => + · rw [ite_eq_left hev] + exact Finset.sum_eq_zero (fun φ _ => ite_eq_right (fun hφ => hag (throughAgree_of_edgeOddBoundaryMatch hbnd hφ))) - · rw [if_neg hev] + · rw [ite_eq_right hev] end EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean index 8c4f814aff..3988e10dc2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean @@ -22,8 +22,7 @@ namespace RS namespace EdgeSubset -open Fragment Classical - +open Fragment variable {L : Type} /-- Transporting the colouring sum along an equality of subsets. -/ @@ -66,7 +65,7 @@ theorem edgeTermAt_eq_zero_of_not_closed [LinearOrder L] {V : Fragment L} (hc : ¬ ∀ f ∈ s, V.pairing f ∈ s) (C : ℕ) : edgeTermAt h 𝒟 st s C = 0 := by unfold edgeTermAt - rw [dif_neg hc] + rw [dite_eq_right hc] open Classical in /-- And off subsets that do not match the boundary state. -/ @@ -78,8 +77,8 @@ theorem edgeTermAt_eq_zero_of_not_matches [LinearOrder L] {V : Fragment L} edgeTermAt h 𝒟 st s C = 0 := by unfold edgeTermAt by_cases hc : ∀ f ∈ s, V.pairing f ∈ s - · rw [dif_pos hc, dif_neg hbnd] - · rw [dif_neg hc] + · rw [dite_eq_left hc, dite_eq_right hbnd] + · rw [dite_eq_right hc] open Classical in /-- And off non-Eulerian subsets. -/ @@ -91,10 +90,10 @@ theorem edgeTermAt_eq_zero_of_not_eulerian [LinearOrder L] {V : Fragment L} (hE : ¬ (EdgeSubset.mk s hc).Eulerian) (C : ℕ) : edgeTermAt h 𝒟 st s C = 0 := by unfold edgeTermAt - rw [dif_pos hc] + rw [dite_eq_left hc] by_cases hbnd : genBoundarySubsetMatches V s st - · rw [dif_pos hbnd, dif_neg hE] - · rw [dif_neg hbnd] + · 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 @@ -107,13 +106,13 @@ theorem edgeTermAt_eq_zero_of_not_canon [LinearOrder L] {V : Fragment L} (hne : ¬ Nonempty (EdgeSubset.mk s hc).CanonData) (C : ℕ) : edgeTermAt h 𝒟 st s C = 0 := by unfold edgeTermAt - rw [dif_pos hc] + rw [dite_eq_left hc] by_cases hbnd : genBoundarySubsetMatches V s st - · rw [dif_pos hbnd] + · rw [dite_eq_left hbnd] by_cases hE : (EdgeSubset.mk s hc).Eulerian - · rw [dif_pos hE, dif_neg hne] - · rw [dif_neg hE] - · rw [dif_neg hbnd] + · 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. -/ @@ -129,7 +128,7 @@ theorem edgeTermAt_pos [LinearOrder L] {V : Fragment L} (EdgeSubset.mk s hc).edgeSum h st hbnd (𝒟 s hc hE hne).2 := by unfold edgeTermAt - rw [dif_pos hc, dif_pos hbnd, dif_pos hE, dif_pos hne] + rw [dite_eq_left hc, dite_eq_left hbnd, dite_eq_left hE, dite_eq_left hne] /-! ## One open cut diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/Eulerian.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/Eulerian.lean index 6837a094d4..f0698f7813 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/Eulerian.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/Eulerian.lean @@ -63,8 +63,8 @@ noncomputable def transport {W₁ W₂ : Fragment α} (e : W₁.Equiv W₂) : 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 - letI := Classical.decEq (W₂.Vertex ⊕ α) - letI := Classical.decEq (W₁.Vertex ⊕ α) + 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, @@ -104,7 +104,7 @@ theorem transport_symm_transport {W₁ W₂ : Fragment α} transport e.symm (transport e F) = F := by ext f rw [mem_transport_iff, mem_transport_iff] - show e.flagEquiv.symm (e.flagEquiv.symm.symm f) ∈ F.flags ↔ _ + 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 @@ -161,7 +161,7 @@ theorem TransitionSystem.transport_walkPerm {W₁ W₂ : Fragment α} (κ.transport e).walkPerm = (transportFlagsEquiv e F).permCongr κ.walkPerm := by ext x - show e.flagEquiv (κ.match_ (e.flagEquiv.symm (W₂.pairing x.val))) = _ + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ExactPairingInstance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ExactPairingInstance.lean index 47dead375a..9f0e4a5dee 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ExactPairingInstance.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ExactPairingInstance.lean @@ -81,7 +81,7 @@ noncomputable instance strandExactPairing : coevaluation' := coevClass f evaluation' := evClass f coevaluation_evaluation' := by - show HomSpace.comp f 1 3 1 + 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 _)) @@ -93,7 +93,7 @@ noncomputable instance strandExactPairing : HomSpace.comp_id_left, HomSpace.comp_id_left] exact snake_right f evaluation_coevaluation' := by - show HomSpace.comp f 1 3 1 + 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 _)) @@ -110,7 +110,7 @@ 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 - show HomSpace.comp f 2 2 0 + change HomSpace.comp f 2 2 0 (bundleMapClass f (transposeEquiv 1 1)) (evClass f) = evClass f rw [← braidClass_eq_bmc] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FibreValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FibreValue.lean index bbf0aaeecb..c97a1bc8a0 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FibreValue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FibreValue.lean @@ -23,7 +23,7 @@ data with different boundary pairings whose signed values differ. namespace RS -open scoped Classical + variable {α : Type} @@ -56,7 +56,7 @@ theorem throughValueC_eq_signedValueAt (hne : Nonempty F.CanonData) : F.throughValueC hM st hbnd = F.signedValueAt hM st hbnd (Classical.choice hne).1 := by - rw [throughValueC, dif_pos hne, + rw [throughValueC, dite_eq_left hne, signedValueAt_eq hM st hbnd (Classical.choice hne).2.val (Classical.choice hne).2.prop] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlagGraph.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlagGraph.lean index f4753d7552..00c1992f73 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlagGraph.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlagGraph.lean @@ -49,20 +49,20 @@ def strand : Fragment (Fin 2) where 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 := - dif_pos 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 := - dif_neg 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, dif_pos (by decide)] + rw [gluePair, dite_eq_left (by decide)] rfl /-- Closing the strand onto itself leaves no flags. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignForm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignForm.lean index 5ade2a6ff1..8e462a82fb 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignForm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignForm.lean @@ -18,7 +18,7 @@ bookkeeping the paired step of Proposition 3 runs on. namespace RS -open scoped Classical + variable {α : Type} {ℓ : ℕ} @@ -39,14 +39,14 @@ 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, if_pos ha] + 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, if_neg ha] + simp only [flipColours, ite_eq_right ha] /-- The triangular-number increment `T (n+1) = T n + n`. -/ private theorem tri_succ (n : ℕ) : @@ -143,7 +143,7 @@ theorem flipSignProd_formula (f : α → Fin (2 * ℓ)) 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, if_pos rfl, if_neg 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 _ _ @@ -152,7 +152,7 @@ theorem flipSignProd_formula (f : α → Fin (2 * ℓ)) 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, if_neg h1, if_pos rfl, + 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 _ _ @@ -160,14 +160,14 @@ theorem flipSignProd_formula (f : α → Fin (2 * ℓ)) = (flipLabels L).count a := by rw [List.count_cons_of_ne (Ne.symm h1), List.count_cons_of_ne (Ne.symm h2)] - rw [hc, if_neg h1, if_neg 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 [if_pos (Finset.mem_insert_self p.1 _), - if_pos (Finset.mem_insert_of_mem (Finset.mem_insert_self p.2 _))] + 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 /-- **The even corollary**: a flip sequence in which every label diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.lean index c76e55c1fa..01f8c94221 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.lean @@ -18,7 +18,7 @@ sequence in which every label occurs evenly contributes exactly namespace RS -open scoped Classical + variable {α : Type} {ℓ : ℕ} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.lean index 9dda4b5ec2..0e2187da0c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.lean @@ -32,7 +32,7 @@ branches, and each branch uses a different subset of it -/ namespace RS -open scoped Classical + variable {α : Type} @@ -74,7 +74,6 @@ theorem fourLabel_parity_sep [LinearOrder α] 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] @@ -114,7 +113,6 @@ theorem fourLabel_parity_nonsep [LinearOrder α] 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] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean index 85490a9e8a..9e204ecb72 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean @@ -40,7 +40,7 @@ def refl (W : Fragment α) : Equiv W W where flagEquiv := _root_.Equiv.refl _ vertexEquiv := _root_.Equiv.refl _ attach_comm := fun f => by - show W.attach f = (W.attach f).map (_root_.Equiv.refl _) id + 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 @@ -51,12 +51,12 @@ def symm (e : Equiv W₁ W₂) : Equiv W₂ W₁ where vertexEquiv := e.vertexEquiv.symm attach_comm := fun f => by have h := e.attach_comm (e.flagEquiv.symm f) - simp at h + simp? 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 at h + simp? at h rw [← h] simp circles_eq := e.circles_eq.symm @@ -66,11 +66,11 @@ def trans (e₁ : Equiv W₁ W₂) (e₂ : Equiv W₂ W₃) : Equiv W₁ W₃ wh flagEquiv := e₁.flagEquiv.trans e₂.flagEquiv vertexEquiv := e₁.vertexEquiv.trans e₂.vertexEquiv attach_comm := fun f => by - simp [_root_.Equiv.trans_apply] + simp? [_root_.Equiv.trans_apply] rw [e₂.attach_comm, e₁.attach_comm] rcases W₁.attach f with v | ℓ <;> simp pairing_comm := fun f => by - simp [_root_.Equiv.trans_apply] + simp? [_root_.Equiv.trans_apply] rw [e₁.pairing_comm, e₂.pairing_comm] circles_eq := e₁.circles_eq.trans e₂.circles_eq @@ -132,15 +132,15 @@ def disjUnionCongr (e₁ : Equiv W₁ W₂) (e₂ : Equiv V₁ V₂) : pairing_comm := fun f => by cases f with | inl g => - show Sum.inl (e₁.flagEquiv (W₁.pairing g)) = + change Sum.inl (e₁.flagEquiv (W₁.pairing g)) = Sum.inl (W₂.pairing (e₁.flagEquiv g)) rw [e₁.pairing_comm] | inr g => - show Sum.inr (e₂.flagEquiv (V₁.pairing g)) = + change Sum.inr (e₂.flagEquiv (V₁.pairing g)) = Sum.inr (V₂.pairing (e₂.flagEquiv g)) rw [e₂.pairing_comm] circles_eq := by - show W₁.circles + V₁.circles = W₂.circles + V₂.circles + change W₁.circles + V₁.circles = W₂.circles + V₂.circles rw [e₁.circles_eq, e₂.circles_eq] /-! ### Glue-pair congruence -/ @@ -159,11 +159,11 @@ def survivingFlagEquiv (e : Equiv W₁ W₂) (i j : α) : 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 at h1 + simp? at h1 rw [e.boundaryFlag_comm i] at h1 exact h1 · have h1 := congrArg e.flagEquiv h - simp at h1 + simp? at h1 rw [e.boundaryFlag_comm j] at h1 exact h1⟩ left_inv f := Subtype.ext (by simp) @@ -216,10 +216,10 @@ def gluePairClosedCongr attach_comm := fun f => e.survivingFlagEquiv_glueAttach i j f pairing_comm := fun f => by apply Subtype.ext - show e.flagEquiv (W₁.pairing f.val) = W₂.pairing (e.flagEquiv f.val) + change e.flagEquiv (W₁.pairing f.val) = W₂.pairing (e.flagEquiv f.val) exact e.pairing_comm f.val circles_eq := by - show W₁.circles + 1 = W₂.circles + 1 + change W₁.circles + 1 = W₂.circles + 1 rw [e.circles_eq] /-! #### Rewire commutation -/ @@ -231,7 +231,7 @@ private theorem rewire_val_of_eq_left {W : Fragment α} {i 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 [dif_pos hfi] + unfold rewire; simp [dite_eq_left hfi] /-- The `.val` of a `rewire` in the second branch (partner is `j`'s boundary flag). -/ @@ -241,7 +241,7 @@ private theorem rewire_val_of_eq_right {W : Fragment α} {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 [dif_neg hfi, dif_pos hfj] + 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). -/ @@ -251,7 +251,7 @@ private theorem rewire_val_of_ne {W : Fragment α} {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 [dif_neg hfi, dif_neg hfj] + unfold rewire; simp [dite_eq_right hfi, dite_eq_right hfj] /-- The open case: the flag equivalence commutes with rewiring. -/ private theorem survivingFlagEquiv_rewire @@ -267,7 +267,7 @@ private theorem survivingFlagEquiv_rewire 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] - show e.flagEquiv (rewire hopen₁ f).val = (rewire hopen₂ g).val + 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 ═══════ @@ -279,7 +279,7 @@ private theorem survivingFlagEquiv_rewire exact e.flagEquiv.injective h have hfj₂ : W₂.pairing g.val = W₂.boundaryFlag j := by rw [hgval, ← e.pairing_comm, hfj, e.boundaryFlag_comm] - show e.flagEquiv (rewire hopen₁ f).val = (rewire hopen₂ g).val + 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] @@ -294,7 +294,7 @@ private theorem survivingFlagEquiv_rewire apply hfj rw [← e.boundaryFlag_comm j, ← e.pairing_comm] at h exact e.flagEquiv.injective h - show e.flagEquiv (rewire hopen₁ f).val = (rewire hopen₂ g).val + 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] @@ -319,11 +319,11 @@ def gluePairCongr (hij : i ≠ j) : unfold gluePair split · rename_i h₁ - rw [dif_pos ((e.gluePair_case_preserved i j).mp 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 [dif_neg (mt (e.gluePair_case_preserved i j).mpr 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueAmbient.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueAmbient.lean index bf7008a7bd..c0e3d16324 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueAmbient.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueAmbient.lean @@ -94,6 +94,87 @@ private theorem glueAttach_of_label {W : Fragment α} {i 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. -/ @@ -107,71 +188,137 @@ private noncomputable def gluePairClosed_disjUnion (W : Fragment α) (V : (ambientLabelEquiv i j)) where flagEquiv := ambientFlagEquiv W V i j vertexEquiv := _root_.Equiv.refl (W.Vertex ⊕ V.Vertex) - attach_comm f := 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 - show (W.attach g).map Sum.inl Sum.inl = _; rw [ha]; rfl - rw [glueAttach_of_vertex f' hf', - glueAttach_of_vertex ⟨g, hg⟩ ha] + attach_comm := gluePairClosed_disjUnion_attach_comm W V hclosed + pairing_comm := 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 - · -- 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 - show (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] + · 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 - 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)) => + · -- 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 = 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 - show (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 - show (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 - pairing_comm f := by - rcases f with ⟨g, hg⟩ | g - · apply Subtype.ext - show Sum.inl (W.pairing g) = (W.disjUnion V).pairing (Sum.inl g) - rfl - · apply Subtype.ext - show Sum.inr (V.pairing g) = (W.disjUnion V).pairing (Sum.inr g) - rfl - circles_eq := by - show (W.circles + 1) + V.circles = (W.circles + V.circles) + 1 - omega + 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 @@ -187,113 +334,10 @@ private noncomputable def gluePairOpen_disjUnion (W : Fragment α) (V : Fragment (ambientLabelEquiv i j)) where flagEquiv := ambientFlagEquiv W V i j vertexEquiv := _root_.Equiv.refl (W.Vertex ⊕ V.Vertex) - attach_comm f := 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 - show (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 - show (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 - show (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 - show (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 - pairing_comm 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 [dif_pos (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 [dif_neg (show (W.disjUnion V).pairing (Sum.inl g) ≠ - (W.disjUnion V).boundaryFlag (Sum.inl i) from - fun h => hfi (Sum.inl.inj h)), - dif_pos (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 [dif_neg (show (W.disjUnion V).pairing (Sum.inl g) ≠ - (W.disjUnion V).boundaryFlag (Sum.inl i) from - fun h => hfi (Sum.inl.inj h)), - dif_neg (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 [dif_neg (show (W.disjUnion V).pairing (Sum.inr g) ≠ - (W.disjUnion V).boundaryFlag (Sum.inl i) from - Sum.inr_ne_inl), - dif_neg (show (W.disjUnion V).pairing (Sum.inr g) ≠ - (W.disjUnion V).boundaryFlag (Sum.inl j) from - Sum.inr_ne_inl)] - rfl + attach_comm := gluePairOpen_disjUnion_attach_comm W V hij hopen + pairing_comm := gluePairOpen_disjUnion_pairing_comm W V hij hopen circles_eq := by - show W.circles + V.circles = (W.circles + V.circles) + change W.circles + V.circles = (W.circles + V.circles) rfl /-- A single-pair glue commutes with extending the ambient @@ -314,7 +358,7 @@ noncomputable def gluePairDisjUnion (W : Fragment α) (V : Fragment β) ((W.disjUnion V).boundaryFlag (Sum.inl i)) = (W.disjUnion V).boundaryFlag (Sum.inl j) := congrArg Sum.inl hclosed - rw [dif_pos hunion] + rw [dite_eq_left hunion] exact gluePairClosed_disjUnion W V hclosed · -- open case: W's pair is open, so union's pair is open rename_i hopen @@ -322,7 +366,7 @@ noncomputable def gluePairDisjUnion (W : Fragment α) (V : Fragment β) ((W.disjUnion V).boundaryFlag (Sum.inl i)) ≠ (W.disjUnion V).boundaryFlag (Sum.inl j) := fun h => hopen (Sum.inl.inj h) - rw [dif_neg hunion] + rw [dite_eq_right hunion] exact gluePairOpen_disjUnion W V hij hopen /-- The label condition transported along a relabelling. -/ @@ -345,7 +389,7 @@ private theorem relabelGlueAttach_aux (W : Fragment α) (e : α ≃ β) · 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 - show (W.attach f.val).map id e = _ + change (W.attach f.val).map id e = _ rw [ha]; rfl)] rfl · have h1 : ℓ ≠ e.symm i := @@ -360,7 +404,7 @@ private theorem relabelGlueAttach_aux (W : Fragment α) (e : α ≃ β) f ha h1 h2, glueAttach_of_label f (show (W.relabel e).attach f.val = Sum.inr (e ℓ) from by - show (W.attach f.val).map id e = _ + change (W.attach f.val).map id e = _ rw [ha]; rfl) h1' h2'] rfl @@ -432,7 +476,7 @@ noncomputable def gluePairSwap (W : Fragment α) {i j : α} gluePair_eq_closed (Ne.symm hij) hclosed'] refine ⟨flagE.symm, _root_.Equiv.refl _, fun f => ?_, fun f => ?_, rfl⟩ - · show (glueAttach W j i (flagE.symm f)).map id + · 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 | ℓ @@ -460,7 +504,7 @@ noncomputable def gluePairSwap (W : Fragment α) {i j : α} gluePair_eq_open (Ne.symm hij) hopen'] refine ⟨flagE.symm, _root_.Equiv.refl _, fun f => ?_, fun f => ?_, rfl⟩ - · show (glueAttach W j i (flagE.symm f)).map id + · 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 | ℓ @@ -480,26 +524,26 @@ noncomputable def gluePairSwap (W : Fragment α) {i j : α} obtain ⟨p2, hp2, hv2⟩ := h2 rw [hp1, hp2] exact congrArg Sum.inr (Subtype.ext (hv1.trans hv2.symm)) - · show flagE.symm (rewire hclosed f) = rewire hopen' (flagE.symm f) + · 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 [dif_pos hfi, - dif_neg (show ¬ W.pairing ((flagE.symm f).val) = + rw [dite_eq_left hfi, + dite_eq_right (show ¬ W.pairing ((flagE.symm f).val) = W.boundaryFlag j from hfj), - dif_pos (show W.pairing ((flagE.symm f).val) = + 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 [dif_neg hfi, dif_pos hfj, - dif_pos (show W.pairing ((flagE.symm f).val) = + · 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 [dif_neg hfi, dif_neg hfj, - dif_neg (show ¬ W.pairing ((flagE.symm f).val) = + · rw [dite_eq_right hfi, dite_eq_right hfj, + dite_eq_right (show ¬ W.pairing ((flagE.symm f).val) = W.boundaryFlag j from hfj), - dif_neg (show ¬ W.pairing ((flagE.symm f).val) = + dite_eq_right (show ¬ W.pairing ((flagE.symm f).val) = W.boundaryFlag i from hfi)] exact Subtype.ext rfl @@ -512,12 +556,12 @@ noncomputable def disjUnionComm (W₁ : Fragment α) (W₂ : Fragment β) : vertexEquiv := Equiv.sumComm W₁.Vertex W₂.Vertex attach_comm := fun f => by rcases f with f | f - · show ((W₁.attach f).map Sum.inr Sum.inr).map id + · 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 - · show ((W₂.attach f).map Sum.inl Sum.inl).map id + · 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 @@ -525,7 +569,7 @@ noncomputable def disjUnionComm (W₁ : Fragment α) (W₂ : Fragment β) : pairing_comm := fun f => by rcases f with f | f <;> rfl circles_eq := by - show W₁.circles + W₂.circles = W₂.circles + W₁.circles + change W₁.circles + W₂.circles = W₂.circles + W₁.circles omega end Fragment diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean index ddf5f2859b..f581b62ec5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean @@ -26,8 +26,7 @@ namespace RS namespace EdgeSubset -open Fragment Equiv Classical - +open Fragment Equiv /-! ## The relabel step `glueInterface` relabels after every glue, so the invariant has to @@ -136,7 +135,7 @@ theorem chordInv_glueOpen ((W.gluePairOpen i j hij hopen).boundaryFlag l) hlg).val := congrArg Subtype.val hgf by_cases h1 : chordInv (Fl) κ l.val = i - · rw [if_pos h1] + · 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 κ @@ -145,7 +144,7 @@ theorem chordInv_glueOpen rw [hLHS, hpm] exact (boundaryFlag_chordInv (Fl) κ hbj).symm · by_cases h2 : chordInv (Fl) κ l.val = j - · rw [if_neg h1, if_pos h2] + · 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 κ @@ -153,7 +152,7 @@ theorem chordInv_glueOpen refine W.boundaryFlag_injective ?_ rw [hLHS, hpm] exact (boundaryFlag_chordInv (Fl) κ hbi).symm - · rw [if_neg h1, if_neg h2] + · rw [ite_eq_right h1, ite_eq_right h2] have hni : κ.pathMatch (W.boundaryFlag l.val) hll ≠ W.boundaryFlag i := by rw [← hlf] @@ -197,28 +196,28 @@ theorem cutMatching_glueOpen_edge ⟨y.val.val, fun hx => y.prop.1 (Subtype.ext hx), fun hx => y.prop.2 (Subtype.ext hx)⟩ hlg hbi hbj - show (chordInv (Fg) + change (chordInv (Fg) (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) ⟨y.val.val, _⟩).val = _ rw [hkey] - show _ = ((if (cutMatching (Fl) κ o).edge y.val = ⟨i, hbi⟩ then + 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 [if_pos h1, if_pos (Subtype.ext h1 : + · 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 [if_neg h1, if_pos h2, - if_neg (fun hx => h1 (congrArg Subtype.val hx)), - if_pos (Subtype.ext h2 : + · 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 [if_neg h1, if_neg h2, - if_neg (fun hx => h1 (congrArg Subtype.val hx)), - if_neg (fun hx => h2 (congrArg Subtype.val hx))] + · 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 @@ -339,7 +338,7 @@ theorem openCircuitCount_add_unionCount_glueOpen hAij hBij (DirMatching.alternating_map _ hABg) heM heN have hc1 : (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).openCircuitCount = κ.openCircuitCount + 1 := by - rw [hδ, hun, if_pos (hlink.mpr hcl)] + rw [hδ, hun, ite_eq_left (hlink.mpr hcl)] rw [hc1] omega · have hMij : (cutMatching (Fl) κ o).edge ⟨i, hbi⟩ ≠ ⟨j, hbj⟩ := @@ -362,7 +361,7 @@ theorem openCircuitCount_add_unionCount_glueOpen hBij hAij (DirMatching.alternating_map _ hABg) heM heN have hc0 : (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).openCircuitCount = κ.openCircuitCount := by - rw [hδ, hun, if_neg (fun hL => hcl (hlink.mp hL)), add_zero] + rw [hδ, hun, ite_eq_right (fun hL => hcl (hlink.mp hL)), add_zero] rw [hc0] omega @@ -441,20 +440,20 @@ theorem dropSubset_rewire_closed (s : Finset W.Flag) 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 - show (rewire hopen f).val ∈ s + change (rewire hopen f).val ∈ s rw [show (rewire hopen f).val = W.pairing (W.boundaryFlag j) - from by unfold rewire; rw [dif_pos h1]] + 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 - show (rewire hopen f).val ∈ s + change (rewire hopen f).val ∈ s rw [show (rewire hopen f).val = W.pairing (W.boundaryFlag i) - from by unfold rewire; rw [dif_neg h1, dif_pos h2]] + 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 [dif_neg h1, dif_neg h2]] + unfold rewire; rw [dite_eq_right h1, dite_eq_right h2]] exact hs.1 _ hf end GlueChord diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChords.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChords.lean index 1509eb3759..e300a0a715 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChords.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChords.lean @@ -19,7 +19,7 @@ lives. namespace RS -open scoped Classical + variable {α : Type} @@ -50,7 +50,7 @@ theorem cutPartner_eq_some [LinearOrder α] (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, dif_pos hex] + rw [cutPartner, dite_eq_left hex] have hch := Classical.choose_spec hex have hxy : x ≠ y := by intro he @@ -114,6 +114,6 @@ theorem glueChords_cross [LinearOrder α] {(min x y, max x y)} := by rw [glueChords, cutPartner_eq_some hP hi, cutPartner_eq_some hP hj] - simp only [if_neg hxj] + 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 index 2bbb817bdf..9fbac6bfcf 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean @@ -34,7 +34,7 @@ rewire. namespace RS -open scoped Classical + /-! ### Permutation counting helpers: `sumCongr` -/ @@ -89,16 +89,6 @@ section GenericWalk variable {F : EdgeSubset W} -/-- 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] - /-- Iterates of a periodic flag are periodic. -/ theorem periodicFlag_iterWalk (κ : F.RelTransitionSystem) {f : W.Flag} (hf : κ.PeriodicFlag f) (m : ℕ) : @@ -298,7 +288,7 @@ theorem iterWalk_val_of_glued_avoids 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) - show (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + change (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ').match_ (W.pairing (iterWalk (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') g.val m)) = @@ -331,7 +321,7 @@ theorem iterWalk_val_of_internal have hp := hcontW m (by omega) rw [hval] at hp obtain ⟨h1, h2⟩ := internal_surviving i j hp - show (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + change (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ').match_ (W.pairing (iterWalk (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') g.val m)) = @@ -707,7 +697,7 @@ theorem walkPermPeriodic_notLinked (κ' : (Fg).RelTransitionSystem) ((RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ').periodicFlags_sub hf) apply Subtype.ext - show (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + change (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ').match_ (W.pairing f) = (κ'.match_ ((W.gluePairOpen i j hij hopen).pairing ⟨f, h1, h2⟩)).val @@ -824,7 +814,7 @@ omit hb hbo in theorem splice_period : iterWalk κ' (κ'.match_ x) k = κ'.match_ x := by obtain ⟨k0, rfl⟩ : ∃ k0, k = k0 + 1 := ⟨k - 1, by omega⟩ - show κ'.match_ ((W.gluePairOpen i j hij hopen).pairing + 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 @@ -939,6 +929,277 @@ noncomputable def spliceFlag (κ' : (Fg).RelTransitionSystem) ⟨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) + (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))) : + ∀ 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 @@ -961,11 +1222,6 @@ theorem exists_walkPerm_linked (κ' : (Fg).RelTransitionSystem) (Equiv.sumCongr (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ').walkPermPeriodic (Equiv.sumCongr (finRotate k) (finRotate k))) := by - -- ═══════ SETUP: THE TWO SPLICED CYCLES ═══════ - -- The open glue rewires the two interface flags; the walk out of - -- `bf_i` and the reversed walk out of `bf_j` splice into the two - -- cycles `SA`, `SB`, whose basic properties are collected here. - -- interface rewires have hpIpJ : (W.gluePairOpen i j hij hopen).pairing (partnerSurvI hopen) = partnerSurvJ hopen := gluePairOpen_pairing_interface_i hij hopen _ @@ -1005,28 +1261,12 @@ theorem exists_walkPerm_linked (κ' : (Fg).RelTransitionSystem) (partnerSurvJ hopen) (partnerSurvI hopen) (W.boundaryFlag j) (W.boundaryFlag i) rfl rfl hpIpJ k hk1 hcontB htermB - 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_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_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 hSA_mod := splice_mod hij hopen s' hc' hc κ' (partnerSurvI hopen) (partnerSurvJ hopen) (W.boundaryFlag i) (W.boundaryFlag j) rfl rfl hpJpI @@ -1035,105 +1275,7 @@ theorem exists_walkPerm_linked (κ' : (Fg).RelTransitionSystem) (partnerSurvJ hopen) (partnerSurvI hopen) (W.boundaryFlag j) (W.boundaryFlag i) rfl rfl hpIpJ k hk1 hcontB htermB - 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 - 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 - have hinj : 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 - 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 + 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 @@ -1156,7 +1298,7 @@ theorem exists_walkPerm_linked (κ' : (Fg).RelTransitionSystem) exact hcEq refine ⟨Sum.inr (Sum.inr ⟨((k - 1) + c) % k, Nat.mod_lt _ (by omega)⟩), Subtype.ext ?_⟩ - show iterWalk κ' (κ'.match_ (partnerSurvJ hopen)) + change iterWalk κ' (κ'.match_ (partnerSurvJ hopen)) (((k - 1) + c) % k) = g rw [← hSB_mod ((k - 1) + c)] exact hstep @@ -1170,93 +1312,14 @@ theorem exists_walkPerm_linked (κ' : (Fg).RelTransitionSystem) exact hcEq refine ⟨Sum.inr (Sum.inl ⟨((k - 1) + c) % k, Nat.mod_lt _ (by omega)⟩), Subtype.ext ?_⟩ - show iterWalk κ' (κ'.match_ (partnerSurvI hopen)) + 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 : ∀ 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 - 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 ?_) - show (κ'.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 ?_ - show 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 ?_ - show 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] + have key := linked_walkMap_equivariant hij hopen s' hc' hc κ' hbi hbj k hk1 hcontA htermA hperA hperB apply Equiv.ext intro xg obtain ⟨z, rfl⟩ := hsurj xg @@ -1299,6 +1362,7 @@ theorem openCircuitCount_linked_chain (κ' : (Fg).RelTransitionSystem) 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. -/ @@ -1310,7 +1374,7 @@ theorem openCircuitCount_glueOpen_participating (κ' : (Fg).RelTransitionSystem) (if InterfaceLinked hij hopen s' hc' hc κ' hpi then 1 else 0) := by by_cases hL : InterfaceLinked hij hopen s' hc' hc κ' hpi - · rw [if_pos hL] + · 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) @@ -1328,7 +1392,7 @@ theorem openCircuitCount_glueOpen_participating (κ' : (Fg).RelTransitionSystem) (boundaryFlagI_mem_boundaryFlags hij hopen s' hc hpi) (boundaryFlagJ_mem_boundaryFlags hij hopen s' hc' hc hpi) k hk1 hcontA htermA - · rw [if_neg hL, add_zero] + · rw [ite_eq_right hL, add_zero] exact (openCircuitCount_notLinked hij hopen s' hc' hc κ' hpi hL).symm diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueComm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueComm.lean index 986db638a1..4138963fef 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueComm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueComm.lean @@ -179,7 +179,7 @@ private theorem doubleGlueAttach_comm (W : Fragment α) {i j k l : α} -- The restricted pairing sends k's boundary flag to l's in the -- closed ij fragment. -private theorem closedClosed_second_ij [DecidableEq α] +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) @@ -191,7 +191,7 @@ private theorem closedClosed_second_ij [DecidableEq α] -- The restricted pairing sends i's boundary flag to j's in the -- closed kl fragment. -private theorem closedClosed_second_kl [DecidableEq α] +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) @@ -239,7 +239,7 @@ private theorem rewire_val_ne' {W : Fragment α} {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 [dif_neg hfi, dif_neg hfj] + 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 : α} @@ -247,7 +247,7 @@ private theorem rewire_val_left' {W : Fragment α} {i 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 [dif_pos hfi] + 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 : α} @@ -256,10 +256,10 @@ private theorem rewire_val_right' {W : Fragment α} {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 [dif_neg hfi, dif_pos hfj] + 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 [DecidableEq α] +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) @@ -270,7 +270,7 @@ private theorem openOpen_second_open_ij [DecidableEq α] (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 - show (W.gluePairOpen i j hij hopen_ij).pairing + 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 @@ -284,7 +284,7 @@ private theorem openOpen_second_open_ij [DecidableEq α] 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 [DecidableEq α] +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) @@ -295,7 +295,7 @@ private theorem openOpen_second_open_kl [DecidableEq α] (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 - show (W.gluePairOpen k l hkl hopen_kl).pairing + 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 @@ -306,6 +306,370 @@ private theorem openOpen_second_open_kl [DecidableEq α] 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` @@ -333,271 +697,16 @@ private def openOpen_disjoint_equiv [DecidableEq α] (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 - -- 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 - show (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⟩ - · -- ═══════ PARTNER IS bF i ═══════ - -- 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] - · -- ═══════ 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] + attach_comm := openOpen_disjoint_equiv_attach_comm W hij hkl hik hil hjk hjl hopen_ij + hopen_kl hfar_ik hfar_il hfar_jk + pairing_comm := 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 [DecidableEq α] +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) @@ -609,7 +718,7 @@ private theorem closedOpen_second_open [DecidableEq α] exact hopen_kl (congrArg Subtype.val heq) -- The ij glue is closed after an open kl glue. -private theorem closedOpen_second_closed [DecidableEq α] +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) @@ -666,7 +775,7 @@ private def closedOpen_equiv [DecidableEq α] 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. - show (rewire hopen_ij_kl f).val.val = + 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 @@ -731,7 +840,7 @@ private def closedOpen_equiv [DecidableEq α] /-! ### 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 [DecidableEq α] +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) @@ -743,7 +852,7 @@ private theorem openClosed_second_open [DecidableEq α] exact hopen_ij (congrArg Subtype.val heq) -- The kl glue is closed after an open ij glue. -private theorem openClosed_second_closed [DecidableEq α] +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) @@ -798,7 +907,7 @@ private def openClosed_equiv [DecidableEq α] 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. - show (rewire hopen_ij f.val).val = + 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 @@ -851,7 +960,7 @@ private def openClosed_equiv [DecidableEq α] /-! ### 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 [DecidableEq α] +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) @@ -870,7 +979,7 @@ private theorem oneCross_ik_second_open_kl [DecidableEq α] 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 [DecidableEq α] +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) @@ -887,62 +996,120 @@ private theorem oneCross_ik_second_open_ij [DecidableEq α] fun h => hfar_jl (W.pairing_boundaryFlag_comm h) exact hfar_lj (lhs_val.symm ▸ congrArg Subtype.val heq) -/-- Configuration (2), variant {ik}: one cross-edge `W.pairing(bFi) = bFk`. -Both glues are open in both orders; circles = `W.circles`. -/ -private def oneCross_ik_equiv [DecidableEq α] +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) : - ((W.gluePairOpen i j hij hopen_ij).gluePairOpen + (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)).Equiv - (((W.gluePairOpen k l hkl hopen_kl).gluePairOpen + 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) 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 - -- 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 - show (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) ═══════ + (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 @@ -950,183 +1117,180 @@ private def oneCross_ik_equiv [DecidableEq α] 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 = + -- 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⟩ := - 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 + 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 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 + 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 - 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 + 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 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 + 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] - · 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] + · -- 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`. -/ +private def oneCross_ik_equiv [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)) + (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)) + (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 := oneCross_ik_equiv_attach_comm W hij hkl hik hil hjk hjl hopen_ij hopen_kl + hcross hfar_jl + pairing_comm := 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 [DecidableEq α] +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) @@ -1149,7 +1313,7 @@ private theorem oneCross_il_second_open_kl [DecidableEq α] 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 [DecidableEq α] +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) @@ -1206,7 +1370,7 @@ private def oneCross_il_equiv [DecidableEq α] 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 - show (rewire (oneCross_il_second_open_kl W hij hkl hik hil hjk hjl + 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 @@ -1365,7 +1529,7 @@ private def oneCross_il_equiv [DecidableEq α] /-! ### 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 [DecidableEq α] +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) @@ -1385,7 +1549,7 @@ private theorem oneCross_jk_second_open_kl [DecidableEq α] 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 [DecidableEq α] +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) @@ -1443,7 +1607,7 @@ private def oneCross_jk_equiv [DecidableEq α] 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 - show (rewire (oneCross_jk_second_open_kl W hij hkl hik hil hjk hjl + 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 @@ -1605,7 +1769,7 @@ private def oneCross_jk_equiv [DecidableEq α] /-! ### 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 [DecidableEq α] +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) @@ -1628,7 +1792,7 @@ private theorem oneCross_jl_second_open_kl [DecidableEq α] 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 [DecidableEq α] +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) @@ -1652,6 +1816,230 @@ private theorem oneCross_jl_second_open_ij [DecidableEq α] 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`. -/ private def oneCross_jl_equiv [DecidableEq α] @@ -1675,185 +2063,16 @@ private def oneCross_jl_equiv [DecidableEq α] (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 - show (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] + attach_comm := oneCross_jl_equiv_attach_comm W hij hkl hik hil hjk hjl hopen_ij hopen_kl + hcross hfar_ik + pairing_comm := 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 [DecidableEq α] +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) @@ -1872,7 +2091,7 @@ private theorem twoCross_ikjl_second_closed_kl [DecidableEq α] 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 [DecidableEq α] +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) @@ -1914,7 +2133,7 @@ private def twoCross_ikjl_equiv [DecidableEq α] exact doubleGlueAttach_comm W hik hil hjk hjl f pairing_comm f := by apply Subtype.ext; apply Subtype.ext - show (rewire hopen_ij f.val).val = (rewire hopen_kl + 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 @@ -1949,7 +2168,7 @@ private def twoCross_ikjl_equiv [DecidableEq α] circles_eq := rfl -- Second kl-glue is CLOSED after ij-glue (two crosses, il+jk variant). -private theorem twoCross_iljk_second_closed_kl [DecidableEq α] +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) @@ -1970,7 +2189,7 @@ private theorem twoCross_iljk_second_closed_kl [DecidableEq α] 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 [DecidableEq α] +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) @@ -2015,7 +2234,7 @@ private def twoCross_iljk_equiv [DecidableEq α] exact doubleGlueAttach_comm W hik hil hjk hjl f pairing_comm f := by apply Subtype.ext; apply Subtype.ext - show (rewire hopen_ij f.val).val = (rewire hopen_kl + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCrossDelta.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCrossDelta.lean index af4e792aa3..ce659fd904 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCrossDelta.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCrossDelta.lean @@ -26,7 +26,7 @@ the converse's per-cut splitting carries. namespace RS -open scoped Classical + variable {α : Type} @@ -62,7 +62,7 @@ private theorem diagCrossCount_eq_sum [LinearOrder α] private theorem xInd_self [LinearOrder α] (p : α × α) : xInd p p = 0 := - if_neg (fun h => lt_irrefl _ h.1) + ite_eq_right (fun h => lt_irrefl _ h.1) /-- The two ordered indicators of a chord pair with distinct starts sum to the plain crossing indicator. -/ @@ -73,13 +73,13 @@ private theorem xInd_pair [LinearOrder α] rcases lt_or_gt_of_ne h with hlt | hgt · have e0 : xInd q p = 0 := by unfold xInd - exact if_neg (fun hc => lt_asymm hlt hc.1) + 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 if_neg (fun hc => lt_asymm hgt hc.1) + 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) @@ -192,13 +192,13 @@ private theorem pair_cut_parity [LinearOrder α] 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 [if_pos hI, if_pos hJ, if_neg (fun hc => + · 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 [if_pos hI, if_neg hJ, - if_pos (hxor.mpr (Or.inl ⟨hI, hJ⟩))] - · rw [if_neg hI, if_pos hJ, - if_pos (hxor.mpr (Or.inr ⟨hJ, hI⟩))] - · rw [if_neg hI, if_neg hJ, if_neg (fun hc => + · 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueFold.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueFold.lean index e50c108019..2d6550ff31 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueFold.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueFold.lean @@ -259,7 +259,7 @@ theorem glueList_cons {α : Type} (W : Fragment α) (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 - show glueListAux ((p :: ps).length) W (p :: ps) hp le_rfl = + 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) @@ -284,7 +284,7 @@ private noncomputable def glueListCongr_aux match ps, h, hn with | [], _, _ => exact Equiv.relabelCongr he _ | (i, j) :: ps, h, hlen => - show ((glueListAux n _ _ _ _).relabel _).Equiv + change ((glueListAux n _ _ _ _).relabel _).Equiv ((glueListAux n _ _ _ _).relabel _) exact Equiv.relabelCongr (ih (Equiv.gluePairCongr he h.head_ne) @@ -461,7 +461,7 @@ private noncomputable def gluePair_cast_equiv (W : Fragment α) (e : α ≃ β) 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 - show glueAttach W i j (flagE f) = + 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 | ℓ @@ -492,7 +492,7 @@ private noncomputable def gluePair_cast_equiv (W : Fragment α) (e : α ≃ β) rw [hlhs_eq, hrhs_eq] refine ⟨flagE, _root_.Equiv.refl _, fun f => ?_, fun f => ?_, rfl⟩ · -- attach_comm (same as closed case) - show glueAttach W i j (flagE f) = + 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 | ℓ @@ -513,28 +513,28 @@ private noncomputable def gluePair_cast_equiv (W : Fragment α) (e : α ≃ β) rw [hp1, hp2] exact congrArg Sum.inr (Subtype.ext (hv1.trans hv2.symm)) · -- pairing_comm for open case (rewire) - show flagE (rewire hopen' f) = rewire hclosed (flagE f) + 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 - show W.pairing f.val = W.boundaryFlag i; rw [← hbi]; exact hfi - rw [dif_pos hfi'] + 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 - show ¬(W.pairing f.val = W.boundaryFlag i); rw [← hbi]; exact hfi - rw [dif_neg hfi'] + 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 - show W.pairing f.val = W.boundaryFlag j; rw [← hbj]; exact hfj - rw [dif_pos hfj'] + 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 - show ¬(W.pairing f.val = W.boundaryFlag j); rw [← hbj]; exact hfj - rw [dif_neg hfj'] + 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 @@ -560,7 +560,7 @@ private theorem nonempty_glueList_relabel_aux (n : ℕ) : intro α β W e ps hp hlen have hnil : ps = [] := List.eq_nil_of_length_eq_zero (Nat.le_zero.mp hlen) subst hnil - show Nonempty (((W.relabel e).relabel (foldSurvivingNilEquiv (α + change Nonempty (((W.relabel e).relabel (foldSurvivingNilEquiv (α := β)).symm).Equiv ((W.relabel (foldSurvivingNilEquiv (α := α)).symm).relabel (foldSurvivingMapEquiv e []))) @@ -577,7 +577,7 @@ private theorem nonempty_glueList_relabel_aux (n : ℕ) : match ps, hp, hlen with -- ═══════ The list is empty anyway ═══════ | [], _, _ => - show Nonempty (((W.relabel e).relabel (foldSurvivingNilEquiv (α + change Nonempty (((W.relabel e).relabel (foldSurvivingNilEquiv (α := β)).symm).Equiv ((W.relabel (foldSurvivingNilEquiv (α := α)).symm).relabel (foldSurvivingMapEquiv e []))) @@ -1079,7 +1079,7 @@ private theorem nonempty_glueList_append_aux (n : ℕ) : (liftPairs_wf _ _ h.append_right h.append_sep) (by rw [hlift]) refine ⟨?_⟩ - show ((glueList W ((i, j) :: (ps ++ qs)) h).Equiv _) + 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] : @@ -1297,13 +1297,13 @@ private noncomputable def relabelDisjUnionLeft vertexEquiv := _root_.Equiv.refl _ attach_comm f := by rcases f with f | f - · show ((W.attach f).map Sum.inl Sum.inl).map + · 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 - · show ((W'.attach f).map Sum.inr Sum.inr).map + · 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 @@ -1326,13 +1326,13 @@ private noncomputable def relabelDisjUnionRight vertexEquiv := _root_.Equiv.refl _ attach_comm f := by rcases f with f | f - · show ((W.attach f).map Sum.inl Sum.inl).map + · 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 - · show ((W'.attach f).map Sum.inr Sum.inr).map + · 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 @@ -1364,6 +1364,203 @@ private theorem coercePairsList_inlPairs_comm /-! ### 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 α) @@ -1438,182 +1635,7 @@ private theorem nonempty_glueList_disjUnion_left_aux (inlFoldEquiv (β := β) []).symm)⟩ -- ═══════ Glue the head on the left component, recurse ═══════ | (i, j) :: ps, hp, hlen => - 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 - show 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 ⟨?_⟩ - show ((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) + 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 @@ -1821,7 +1843,7 @@ private theorem nonempty_glueList_swap_aux List.eq_nil_of_length_eq_zero (Nat.le_zero.mp hlen) subst hnil - show Nonempty + change Nonempty ((W.relabel foldSurvivingNilEquiv.symm).Equiv ((W.relabel @@ -1843,7 +1865,7 @@ private theorem nonempty_glueList_swap_aux match ps, hp, hlen with -- ═══════ The list is empty anyway ═══════ | [], _, _ => - show Nonempty + change Nonempty ((W.relabel foldSurvivingNilEquiv.symm).Equiv ((W.relabel @@ -1993,7 +2015,7 @@ private theorem nonempty_glueList_swap_aux := by rw [h_eq]; exact Equiv.refl _ -- Assemble via glueList_cons refine ⟨?_⟩ - show (glueList W + change (glueList W ((j, i) :: ps.map Prod.swap) hp_swap).Equiv ((glueList W ((i, j) :: ps) @@ -2041,7 +2063,7 @@ noncomputable def glueListSwap /-- 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 [DecidableEq α] +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) @@ -2066,6 +2088,7 @@ 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 => @@ -2141,7 +2164,7 @@ private theorem nonempty_glueList_perm_aux (n : ℕ) : | @swap p q ps' => -- swap p q ps' : (q :: p :: ps').Perm (p :: q :: ps') -- hp : PairsWF (q :: p :: ps') - letI := Classical.typeDecidableEq α + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueLedger.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueLedger.lean index adf3c83d8b..3a79c2f641 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueLedger.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueLedger.lean @@ -28,8 +28,7 @@ namespace RS namespace EdgeSubset -open Fragment Equiv Classical - +open Fragment Equiv /-! ## The ledger reads only the matching Both quantities the ledger tracks — the circuit count and the chord @@ -52,7 +51,7 @@ theorem chordInv_congr_matchEq {κ₁ κ₂ : F.RelTransitionSystem} rw [boundaryFlag_chordInv F κ₂ hb, boundaryFlag_chordInv F κ₁ hb, pathMatch_matchEq h hb] · unfold chordInv - rw [dif_neg hb, dif_neg hb] + rw [dite_eq_right hb, dite_eq_right hb] /-- **The cut matching's pairing reads only the matching.** -/ theorem cutMatching_congr_matchEq diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GluePathMatch.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GluePathMatch.lean index 12f33d89ec..c8a7398c7c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GluePathMatch.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GluePathMatch.lean @@ -32,7 +32,7 @@ terms of the `pathMatch` of `κ`: namespace RS -open scoped Classical + namespace EdgeSubset @@ -186,13 +186,13 @@ theorem iterWalk_glueOpen_from rw [hrw] exact hintv refine ⟨?_, ?_⟩ - · show ((RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ + · 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]) - · show (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ + · 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' @@ -232,7 +232,7 @@ theorem boundary_val_of_glueOpen /-- **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} [LinearOrder α'] +theorem pathMatch_exit_unique {α' : Type} {W' : Fragment α'} {F : EdgeSubset W'} (κ : F.RelTransitionSystem) {b : W'.Flag} (hb : b ∈ F.boundaryFlags) (N : ℕ) @@ -321,6 +321,40 @@ theorem pathMatch_glueOpen_of_ne 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 + /-- **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 @@ -345,36 +379,7 @@ theorem pathMatch_glueOpen_hit_i -- ═══════ 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 - have hinvol : ∀ (x : W.Flag) - (hx : x ∈ (EdgeSubset.mk - (liftSubsetOpen hopen s') hc : - EdgeSubset W).boundaryFlags) - (he : κ.pathMatch b'.val hbl = x), - κ.pathMatch x hx = b'.val := by - intro x hx he - subst he - exact κ.pathMatch_invol hbl - + 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 ═══════ @@ -401,16 +406,8 @@ theorem pathMatch_glueOpen_hit_i have hne₂i : κ.pathMatch (W.boundaryFlag j) hbfj ≠ W.boundaryFlag i := by intro hcon - have h1 : ∀ (x : W.Flag) (hx : x ∈ (EdgeSubset.mk - (liftSubsetOpen hopen s') hc : - EdgeSubset W).boundaryFlags) - (he : κ.pathMatch (W.boundaryFlag j) hbfj = x), - κ.pathMatch x hx = W.boundaryFlag j := by - intro x hx he - subst he - exact κ.pathMatch_invol hbfj - have h2 := h1 (W.boundaryFlag i) hbfi hcon - have h3 := hinvol (W.boundaryFlag i) hbfi hhit + 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₂ @@ -429,7 +426,7 @@ theorem pathMatch_glueOpen_hit_i have hb2v : (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + 1)).val = κ.match_ (W.pairing (W.boundaryFlag j)) := by - show ((RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ + 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 = _ @@ -438,7 +435,7 @@ theorem pathMatch_glueOpen_hit_i hpsjint).trans (by rw [partnerSurvJ_val]) have hmem2 : iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + 1) ∈ s' := by - show (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ + 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' @@ -457,26 +454,9 @@ theorem pathMatch_glueOpen_hit_i (g' := iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + 1)) hb2v hmem2 (k₃ - 1) hcontsh - have hadd : ∀ m, iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc - κ) - (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + - 1)) m = - iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + 1 - + m) := by - intro m - induction m with - | zero => rfl - | succ m ih => - show (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ - ((W.gluePairOpen i j hij hopen).pairing - (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) - (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) - b' (k + 1)) m)) = - (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 + 1 + m))) - rw [ih] + 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) ∈ @@ -593,36 +573,7 @@ theorem pathMatch_glueOpen_hit_j 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 : ∀ 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 - have hinvol : ∀ (x : W.Flag) - (hx : x ∈ (EdgeSubset.mk - (liftSubsetOpen hopen s') hc : - EdgeSubset W).boundaryFlags) - (he : κ.pathMatch b'.val hbl = x), - κ.pathMatch x hx = b'.val := by - intro x hx he - subst he - exact κ.pathMatch_invol hbl - + 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) ≠ @@ -653,16 +604,8 @@ theorem pathMatch_glueOpen_hit_j have hne₂j : κ.pathMatch (W.boundaryFlag i) hbfi ≠ W.boundaryFlag j := by intro hcon - have h1 : ∀ (x : W.Flag) (hx : x ∈ (EdgeSubset.mk - (liftSubsetOpen hopen s') hc : - EdgeSubset W).boundaryFlags) - (he : κ.pathMatch (W.boundaryFlag i) hbfi = x), - κ.pathMatch x hx = W.boundaryFlag i := by - intro x hx he - subst he - exact κ.pathMatch_invol hbfi - have h2 := h1 (W.boundaryFlag j) hbfj hcon - have h3 := hinvol (W.boundaryFlag j) hbfj hhit + 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₂ @@ -681,7 +624,7 @@ theorem pathMatch_glueOpen_hit_j have hb2v : (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + 1)).val = κ.match_ (W.pairing (W.boundaryFlag i)) := by - show ((RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ + 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 = _ @@ -690,7 +633,7 @@ theorem pathMatch_glueOpen_hit_j hpsiint).trans (by rw [partnerSurvI_val]) have hmem2 : iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + 1) ∈ s' := by - show (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ + 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' @@ -709,26 +652,9 @@ theorem pathMatch_glueOpen_hit_j (g' := iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + 1)) hb2v hmem2 (k₃ - 1) hcontsh - have hadd : ∀ m, iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc - κ) - (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + - 1)) m = - iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) b' (k + 1 - + m) := by - intro m - induction m with - | zero => rfl - | succ m ih => - show (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ).match_ - ((W.gluePairOpen i j hij hopen).pairing - (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) - (iterWalk (RelTransitionSystem.glueOpen hij hopen s' hc' hc κ) - b' (k + 1)) m)) = - (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 + 1 + m))) - rw [ih] + 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) ∈ @@ -828,7 +754,7 @@ open EdgeSubset Fragment in /-- Participation transports through the open glue at label level. -/ theorem glued_participation_iff - {α : Type} [LinearOrder α] {W : Fragment α} {i j : α} + {α : Type} {W : Fragment α} {i j : α} (hij : i ≠ j) (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) (s' : Finset (SurvivingFlag W i j)) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueRelTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueRelTransport.lean index 512679370d..59f7e84f7a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueRelTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueRelTransport.lean @@ -30,7 +30,7 @@ edge's flags do not participate. namespace RS -open scoped Classical + namespace Fragment @@ -47,7 +47,7 @@ theorem rewire_val_of_ne (h2 : W.pairing f.val ≠ W.boundaryFlag j) : (rewire hopen f).val = W.pairing f.val := by unfold rewire - rw [dif_neg h1, dif_neg h2] + 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. -/ @@ -57,7 +57,7 @@ theorem rewire_eq_partnerSurvJ (h : W.pairing f.val = W.boundaryFlag i) : rewire hopen f = partnerSurvJ hopen := by unfold rewire - rw [dif_pos h] + rw [dite_eq_left h] rfl /-- At the `j`-side of the interface, `rewire` jumps to the far @@ -69,7 +69,7 @@ theorem rewire_eq_partnerSurvI (h : W.pairing f.val = W.boundaryFlag j) : rewire hopen f = partnerSurvI hopen := by unfold rewire - rw [dif_neg hne, dif_pos h] + rw [dite_eq_right hne, dite_eq_left h] rfl /-- A surviving flag whose pairing is the `i`-boundary flag is the @@ -130,7 +130,7 @@ theorem unglueMatch_of_surviving (h : f ≠ W.boundaryFlag i ∧ f ≠ W.boundaryFlag j) : unglueMatch m f = (m ⟨f, h⟩).val := by unfold unglueMatch - rw [dif_pos h] + rw [dite_eq_left h] /-- The same, stated on a surviving flag's underlying flag. -/ theorem unglueMatch_val @@ -138,7 +138,7 @@ theorem unglueMatch_val (g : SurvivingFlag W i j) : unglueMatch m g.val = (m g).val := by unfold unglueMatch - rw [dif_pos g.prop] + 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 @@ -160,7 +160,7 @@ theorem glueMatch_val_of_mem (m : W.Flag → W.Flag) {f' : SurvivingFlag W i j} (h : f' ∈ P) : (glueMatch m P hP f').val = m f'.val := by unfold glueMatch - rw [dif_pos h] + rw [dite_eq_left h] /-- Extend a surviving-flag orientation to all of `W.Flag`: through the subtype on surviving flags, `false` elsewhere. -/ @@ -176,14 +176,14 @@ theorem unglueIsOut_of_surviving (h : f ≠ W.boundaryFlag i ∧ f ≠ W.boundaryFlag j) : unglueIsOut b f = b ⟨f, h⟩ := by unfold unglueIsOut - rw [dif_pos h] + 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 [dif_pos g.prop] + rw [dite_eq_left g.prop] /-! ### The open case -/ @@ -567,7 +567,7 @@ theorem iterWalk_unglueOpen obtain ⟨hval, hmem⟩ := ih (by omega) have hp := hcont k (by omega) refine ⟨?_, ?_⟩ - · show (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + · change (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ').match_ (W.pairing (iterWalk (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') g.val k)) = @@ -611,7 +611,7 @@ theorem iterWalk_unglueOpen_rev W.pairing g.val := gluePairOpen_pairing_val_of_notMem_interface hij hopen s' hc' hni (mem_flags_of_internalFlags _ hg) - show (W.gluePairOpen i j hij hopen).pairing g ∈ + change (W.gluePairOpen i j hij hopen).pairing g ∈ (Fg).internalFlags refine (mem_internalFlags_glueOpen hij hopen s' hc' hc).mpr ?_ rw [hag] @@ -627,7 +627,7 @@ theorem iterWalk_unglueOpen_rev have hstep : iterWalk (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') g.val (k + 1) = (iterWalk κ' g (k + 1)).val := by - show (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + change (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ').match_ (W.pairing (iterWalk (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ') g.val k)) = @@ -744,7 +744,7 @@ theorem walkPermPeriodic_unglueOpen ((RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ').periodicFlags_sub hf) apply Subtype.ext - show (RelTransitionSystem.unglueOpen hij hopen s' hc' hc + change (RelTransitionSystem.unglueOpen hij hopen s' hc' hc κ').match_ (W.pairing f) = (κ'.match_ ((W.gluePairOpen i j hij hopen).pairing ⟨f, h1, h2⟩)).val @@ -1074,7 +1074,7 @@ theorem iterWalk_unglueClosed obtain ⟨hval, hmem⟩ := ih (by omega) have hp := hcont k (by omega) refine ⟨?_, ?_⟩ - · show (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + · change (RelTransitionSystem.unglueClosed hclosed b s' hc' hc κ').match_ (W.pairing (iterWalk (RelTransitionSystem.unglueClosed hclosed b s' hc' hc κ') g.val k)) = @@ -1108,7 +1108,7 @@ theorem iterWalk_unglueClosed_rev intro h0 have hpW := hcontW 0 h0 rw [iterWalk_zero] at hpW - show (W.gluePairClosed i j hclosed).pairing g ∈ + change (W.gluePairClosed i j hclosed).pairing g ∈ (Fg).internalFlags exact (mem_internalFlags_glueClosed hclosed b s' hc' hc).mpr hpW @@ -1123,7 +1123,7 @@ theorem iterWalk_unglueClosed_rev have hstep : iterWalk (RelTransitionSystem.unglueClosed hclosed b s' hc' hc κ') g.val (k + 1) = (iterWalk κ' g (k + 1)).val := by - show (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + change (RelTransitionSystem.unglueClosed hclosed b s' hc' hc κ').match_ (W.pairing (iterWalk (RelTransitionSystem.unglueClosed hclosed b s' hc' hc κ') g.val k)) = @@ -1222,7 +1222,7 @@ theorem walkPermPeriodic_unglueClosed ((RelTransitionSystem.unglueClosed hclosed b s' hc' hc κ').periodicFlags_sub hf) apply Subtype.ext - show (RelTransitionSystem.unglueClosed hclosed b s' hc' hc + change (RelTransitionSystem.unglueClosed hclosed b s' hc' hc κ').match_ (W.pairing f) = (κ'.match_ ((W.gluePairClosed i j hclosed).pairing ⟨f, h1, h2⟩)).val diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/A.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/A.lean index 73bf3c4a42..fd1517213f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/A.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/A.lean @@ -28,7 +28,7 @@ All cuts in the development are therefore ordered. namespace RS -open scoped Classical + /-! ## Evaluation of the extended state -/ @@ -42,7 +42,7 @@ theorem extendPair_left (c c' : Fin k ⊕ Fin (2 * ℓ)) : extendPair i j st c c' i = c := by unfold extendPair - exact dif_pos rfl + exact dite_eq_left rfl /-- At the second glued label. -/ theorem extendPair_right (hij : i ≠ j) @@ -50,7 +50,7 @@ theorem extendPair_right (hij : i ≠ j) (c c' : Fin k ⊕ Fin (2 * ℓ)) : extendPair i j st c c' j = c' := by unfold extendPair - rw [dif_neg (Ne.symm hij), dif_pos rfl] + 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 @@ -59,7 +59,7 @@ theorem extendPair_surviving (a : Fragment.SurvivingLabel α i j) : extendPair i j st c c' a.val = st a := by unfold extendPair - rw [dif_neg a.prop.1, dif_neg a.prop.2] + rw [dite_eq_right a.prop.1, dite_eq_right a.prop.2] end GenBoundaryState @@ -84,6 +84,7 @@ 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 β} @@ -294,7 +295,7 @@ private theorem flatMap_pair_map_val {ℓ : ℕ} | nil => intro _ _; rfl | cons f' t ih => intro H1 H2 - show ((f'.val :: t.map Subtype.val).attachWith + change ((f'.val :: t.map Subtype.val).attachWith (· ∈ (Fl).internalFlags) H1).flatMap ((Fl).coreOddPairFn (κW) φW) = ((f' :: t).attachWith (· ∈ (Fg).internalFlags) H2).flatMap @@ -324,7 +325,7 @@ private theorem map_sign_map_val {ℓ : ℕ} | nil => intro _ _; rfl | cons f' t ih => intro H1 H2 - show ((f'.val :: t.map Subtype.val).attachWith + change ((f'.val :: t.map Subtype.val).attachWith (· ∈ (Fl).internalFlags) H1).map ((Fl).coreOddSignFn (κW) φW) = ((f' :: t).attachWith (· ∈ (Fg).internalFlags) H2).map diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/C.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/C.lean index 7a5169c0d4..0e45297142 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/C.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/C.lean @@ -15,7 +15,7 @@ master splitting identities. namespace RS -open scoped Classical + namespace EdgeSubset @@ -217,7 +217,7 @@ private theorem flatMap_pair_map_val_open {ℓ : ℕ} | nil => intro _ _; rfl | cons f' t ih => intro H1 H2 - show ((f'.val :: t.map Subtype.val).attachWith + change ((f'.val :: t.map Subtype.val).attachWith (· ∈ (Fl).internalFlags) H1).flatMap ((Fl).coreOddPairFn (κW) φW) = ((f' :: t).attachWith (· ∈ (Fg).internalFlags) H2).flatMap @@ -246,7 +246,7 @@ private theorem map_sign_map_val_open {ℓ : ℕ} | nil => intro _ _; rfl | cons f' t ih => intro H1 H2 - show ((f'.val :: t.map Subtype.val).attachWith + change ((f'.val :: t.map Subtype.val).attachWith (· ∈ (Fl).internalFlags) H1).map ((Fl).coreOddSignFn (κW) φW) = ((f' :: t).attachWith (· ∈ (Fg).internalFlags) H2).map @@ -332,7 +332,7 @@ noncomputable def evenPushOpen {k : ℕ} 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 [dif_neg hp1, dif_neg hp2, dif_pos hfi] + 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 @@ -343,7 +343,7 @@ noncomputable def evenPushOpen {k : ℕ} 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 [dif_neg hp1, dif_neg hp2, dif_neg hfi, dif_pos hfj] + 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 @@ -352,18 +352,18 @@ noncomputable def evenPushOpen {k : ℕ} partnerSurvI hopen := eq_partnerSurvI_of_pairing hopen ⟨f.val, hfi, hfj⟩ hpi' - rw [dif_pos hpi', dif_neg hfi, dif_neg hfj] + 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 [dif_neg hpi', dif_pos hpj', dif_neg hfi, - dif_neg hfj] + 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 [dif_neg hpi', dif_neg hpj', dif_neg hfi, - dif_neg hfj] + · 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 @@ -388,10 +388,10 @@ theorem evenPushOpen_agrees {k : ℕ} (evenPushOpen hij hopen s' hc' hc hni ψ').val ⟨g.val, h1⟩ = ψ'.val ⟨g, h2⟩ := by intro g h1 h2 - show (if hfi : g.val = W.boundaryFlag i then _ + 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 [dif_neg g.prop.1, dif_neg g.prop.2] + 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 : ℕ} @@ -399,7 +399,7 @@ theorem evenPushOpen_at_i {k : ℕ} (hP : W.boundaryFlag i ∉ liftSubsetOpen hopen s') : (evenPushOpen hij hopen s' hc' hc hni ψ').val ⟨W.boundaryFlag i, hP⟩ = - ψ'.val ⟨partnerSurvI hopen, hni⟩ := dif_pos rfl + ψ'.val ⟨partnerSurvI hopen, hni⟩ := dite_eq_left rfl /-- The pushed even colouring at the second glued boundary flag. -/ theorem evenPushOpen_at_j {k : ℕ} @@ -409,11 +409,11 @@ theorem evenPushOpen_at_j {k : ℕ} ⟨W.boundaryFlag j, hP⟩ = ψ'.val ⟨partnerSurvJ hopen, hnj_of hij hopen s' hc' hni⟩ := by - show (if hfi : W.boundaryFlag j = W.boundaryFlag i then _ + change (if hfi : W.boundaryFlag j = W.boundaryFlag i then _ else if hfj : W.boundaryFlag j = W.boundaryFlag j then _ else _) = _ - rw [dif_neg (fun hEq => - hij (W.boundaryFlag_injective hEq).symm), dif_pos rfl] + 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 : ℕ} : @@ -578,7 +578,7 @@ theorem evenPushOpen_covers {k ℓ : ℕ} (hpJ (hnl _ (hnj_of hij hopen s' hc' hni)))).trans ?_ refine ((hpI (hnl _ hni)).symm.trans (congrArg ψW.val (Subtype.ext ?_))) - show (partnerSurvI hopen).val = x.val.val + 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 @@ -589,7 +589,7 @@ theorem evenPushOpen_covers {k ℓ : ℕ} refine ((hpJ (hnl _ (hnj_of hij hopen s' hc' hni))).symm.trans (congrArg ψW.val (Subtype.ext ?_))) - show (partnerSurvJ hopen).val = x.val.val + 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) @@ -602,23 +602,23 @@ theorem evenPushOpen_covers {k ℓ : ℕ} 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 => ?_) - show (if hfi : f.val = W.boundaryFlag i then _ + 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 [dif_pos hfi] + · 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 [dif_neg hfi, dif_pos hfj] + · 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 [dif_neg hfi, dif_neg hfj] + · rw [dite_eq_right hfi, dite_eq_right hfj] include hij hc' hc hni in /-- The constrained lifted even sum reindexes along the open @@ -652,7 +652,7 @@ theorem sum_even_open {k ℓ : ℕ} (Sum.inl a₀)) hbndW ψW then G ψW else 0) := by refine (Finset.sum_subset (Finset.subset_univ _) ?_).symm intro ψW _ hnotim - rw [if_neg (fun hmatch => 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ψ'⟩ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSubsetBij.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSubsetBij.lean index c1472635a1..7538643c69 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSubsetBij.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSubsetBij.lean @@ -20,7 +20,7 @@ edge, which closes into a free circle parameterized by a Bool). namespace RS -open scoped Classical + namespace Fragment @@ -161,7 +161,7 @@ theorem boundaryFlagI_mem_liftOpen_iff rw [liftSubsetOpen] apply Finset.mem_union_left apply Finset.mem_union_right - rw [if_pos h] + rw [ite_eq_left h] exact Finset.mem_singleton_self _ /-- The same at the second glued boundary flag. -/ @@ -186,7 +186,7 @@ theorem boundaryFlagJ_mem_liftOpen_iff · intro h rw [liftSubsetOpen] apply Finset.mem_union_right - rw [if_pos h] + rw [ite_eq_left h] exact Finset.mem_singleton_self _ /-! #### Round trips (open case) -/ @@ -343,7 +343,7 @@ theorem boundaryFlagI_mem_liftClosed_iff · simp at h · intro h rw [liftSubsetClosed, Finset.mem_union] - right; rw [if_pos h] + right; rw [ite_eq_left h] exact Finset.mem_insert_self _ _ /-- The same at the second glued boundary flag, on the same bit. -/ @@ -361,7 +361,7 @@ theorem boundaryFlagJ_mem_liftClosed_iff · simp at h · intro h rw [liftSubsetClosed, Finset.mem_union] - right; rw [if_pos h] + right; rw [ite_eq_left h] simp [Finset.mem_insert, Finset.mem_singleton] /-! #### Round trips (closed case) -/ @@ -433,7 +433,7 @@ theorem liftSubsetClosed_pairing_closed · exact absurd hg (boundaryFlagI_not_mem_image s') · split_ifs at hg with hb · rw [liftSubsetClosed, Finset.mem_union]; right - rw [if_pos hb] + rw [ite_eq_left hb] simp [Finset.mem_insert, Finset.mem_singleton] · simp at hg · by_cases hgj : g = W.boundaryFlag j @@ -446,7 +446,7 @@ theorem liftSubsetClosed_pairing_closed · exact absurd hg (boundaryFlagJ_not_mem_image s') · split_ifs at hg with hb · rw [liftSubsetClosed, Finset.mem_union]; right - rw [if_pos hb] + rw [ite_eq_left hb] exact Finset.mem_insert_self _ _ · simp at hg · set gs : SurvivingFlag W i j := ⟨g, hgi, hgj⟩ @@ -498,8 +498,8 @@ theorem deg_liftSubsetOpen_eq (fun f => W.attach f = Sum.inl v)).card = (s'.filter (fun f => glueAttach W i j f = Sum.inl v)).card := by - letI := Classical.decEq (W.Vertex ⊕ α) - letI := Classical.decEq (W.Vertex ⊕ SurvivingLabel α i j) + 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 @@ -533,8 +533,8 @@ theorem deg_liftSubsetClosed_eq (fun f => W.attach f = Sum.inl v)).card = (s'.filter (fun f => glueAttach W i j f = Sum.inl v)).card := by - letI := Classical.decEq (W.Vertex ⊕ α) - letI := Classical.decEq (W.Vertex ⊕ SurvivingLabel α i j) + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GramRank.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GramRank.lean index 6e4a3c819c..ebc81ccd73 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GramRank.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GramRank.lean @@ -22,7 +22,7 @@ of the columns indexed by the ambient space's coordinates. namespace RS -open Classical + /-- **A pairing whose rows lie in a span has rank at most that span's generating set.** -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomCompose.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomCompose.lean index 5072f0cd0b..323c662031 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomCompose.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomCompose.lean @@ -28,7 +28,7 @@ noncomputable def homComposeAux (s t u : ℕ) (composeFinsupp s t u x)) (fun y hy => by refine LinearMap.mem_ker.mpr ?_ - show (LinearMap.ker (connectionMap f.val (s + u))).mkQ + 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) @@ -52,7 +52,7 @@ noncomputable def HomSpace.comp (s t u : ℕ) : map_add' := fun x₁ x₂ => by refine LinearMap.ext fun q => ?_ obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective _ q - show homComposeAux f s t u (x₁ + x₂) + 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, @@ -61,7 +61,7 @@ noncomputable def HomSpace.comp (s t u : ℕ) : map_smul' := fun c x => by refine LinearMap.ext fun q => ?_ obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective _ q - show homComposeAux f s t u (c • x) + 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, @@ -71,7 +71,7 @@ noncomputable def HomSpace.comp (s t u : ℕ) : rw [LinearMap.mem_ker] refine LinearMap.ext fun q => ?_ obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective _ q - show homComposeAux f s t u x + change homComposeAux f s t u x ((LinearMap.ker (connectionMap f.val (t + u))).mkQ y) = 0 rw [homComposeAux_mk] @@ -95,7 +95,7 @@ theorem HomSpace.comp_ofFragment (s 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 - show HomSpace.comp f s t u + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTensor.lean index 065781f680..2d661281ea 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTensor.lean @@ -30,7 +30,7 @@ noncomputable def homTensorAux (s t u v : ℕ) (tensorFinsupp s t u v x)) (fun y hy => by refine LinearMap.mem_ker.mpr ?_ - show (LinearMap.ker (connectionMap f.val + 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] @@ -56,7 +56,7 @@ noncomputable def HomSpace.tensor (s t u v : ℕ) : map_add' := fun x₁ x₂ => by refine LinearMap.ext fun q => ?_ obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective _ q - show homTensorAux f s t u v (x₁ + x₂) + 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, @@ -65,7 +65,7 @@ noncomputable def HomSpace.tensor (s t u v : ℕ) : map_smul' := fun c x => by refine LinearMap.ext fun q => ?_ obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective _ q - show homTensorAux f s t u v (c • x) + 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, @@ -75,7 +75,7 @@ noncomputable def HomSpace.tensor (s t u v : ℕ) : rw [LinearMap.mem_ker] refine LinearMap.ext fun q => ?_ obtain ⟨y, rfl⟩ := Submodule.Quotient.mk_surjective _ q - show homTensorAux f s t u v x + change homTensorAux f s t u v x ((LinearMap.ker (connectionMap f.val (u + v))).mkQ y) = 0 rw [homTensorAux_mk] @@ -99,7 +99,7 @@ theorem HomSpace.tensor_ofFragment (s t 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 - show HomSpace.tensor f s t u v + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceCyclic.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceCyclic.lean index fe29eb44b0..58b273aadf 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceCyclic.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceCyclic.lean @@ -28,7 +28,7 @@ theorem HomSpace.traceMap_comp_comm {t 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 - show traceFunctional f.val t (composeFinsupp t u t x y) = + 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] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceNondegenerate.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceNondegenerate.lean index e9d43d9af0..0cdcc1a181 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceNondegenerate.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceNondegenerate.lean @@ -35,7 +35,7 @@ theorem HomSpace.eq_zero_of_traces_vanish {t u : ℕ} refine mem_ker_of_traces_vanish f.val f.iso_invariant x ?_ intro G exact hq G - show (LinearMap.ker (connectionMap f.val (t + u))).mkQ x = 0 + change (LinearMap.ker (connectionMap f.val (t + u))).mkQ x = 0 rw [Submodule.mkQ_apply] exact (Submodule.Quotient.mk_eq_zero _).mpr hker diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean index a835714797..d81efd3bba 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean @@ -77,7 +77,7 @@ theorem stageEquiv_inr (t t' u : ℕ) (ht : t' ≤ t) (ℓ : Fin (t + u)) : else Sum.inr ⟨t' + (ℓ.val - t), by omega⟩ := by by_cases h₁ : ℓ.val < t' · -- ═══════ CASE: already-glued interface label ═══════ - rw [dif_pos h₁] + rw [dite_eq_left h₁] simp only [stageEquiv, stageShuffle, Equiv.trans_apply, Equiv.sumCongr_apply, Sum.map_inr, finCongr_apply] rw [show finSumFinEquiv.symm @@ -90,10 +90,10 @@ theorem stageEquiv_inr (t t' u : ℕ) (ht : t' ≤ t) (ℓ : Fin (t + u)) : 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 [dif_neg h₁] + · rw [dite_eq_right h₁] by_cases h₂ : ℓ.val < t · -- ═══════ CASE: not-yet-glued interface label ═══════ - rw [dif_pos h₂] + rw [dite_eq_left h₂] simp only [stageEquiv, stageShuffle, Equiv.trans_apply, Equiv.sumCongr_apply, Sum.map_inr, finCongr_apply] rw [show finSumFinEquiv.symm @@ -108,7 +108,7 @@ theorem stageEquiv_inr (t t' u : ℕ) (ht : t' ≤ t) (ℓ : Fin (t + u)) : exact congrArg Sum.inl (Fin.ext (by simp [finSumFinEquiv_apply_right, finCongr_apply]; omega)) · -- ═══════ CASE: outer label ═══════ - rw [dif_neg h₂] + rw [dite_eq_right h₂] simp only [stageEquiv, stageShuffle, Equiv.trans_apply, Equiv.sumCongr_apply, Sum.map_inr, finCongr_apply] rw [show finSumFinEquiv.symm @@ -128,7 +128,7 @@ theorem stageEquiv_inl (t t' u : ℕ) (ht : t' ≤ t) (a : Fin (t' + t')) : else Sum.inl ⟨t + (a.val - t'), by omega⟩ := by by_cases h : a.val < t' · -- ═══════ CASE: strand-in label ═══════ - rw [dif_pos h] + 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') = @@ -138,7 +138,7 @@ theorem stageEquiv_inl (t t' u : ℕ) (ht : t' ≤ t) (a : Fin (t' + t')) : exact congrArg Sum.inl (Fin.ext (by simp [finSumFinEquiv_apply_left, finCongr_apply])) · -- ═══════ CASE: strand-out label ═══════ - rw [dif_neg h] + 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') = @@ -187,7 +187,7 @@ noncomputable def stageZeroEquiv (t u : ℕ) (F : Fragment (Fin (t + u))) : | inl x => exact (IsEmpty.false x).elim | inr g => simp only [Equiv.emptySum_apply_inr] - show F.attach g = + 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)) @@ -220,7 +220,7 @@ theorem stageStep_leftBoundary (t t' u : ℕ) (ht : t' + 1 ≤ t) (stageEquiv t (t' + 1) u ht)).boundaryFlag (Sum.inl ⟨t + t', by omega⟩) = Sum.inl (⟨t', by omega⟩, true) := by - show ((strandBundle (t' + 1)).disjUnion F).boundaryFlag + 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⟩) = @@ -249,7 +249,7 @@ theorem stageStep_rightBoundary (t t' u : ℕ) (ht : t' + 1 ≤ t) (stageEquiv t (t' + 1) u ht)).boundaryFlag (Sum.inr ⟨t', by omega⟩) = Sum.inr (F.boundaryFlag ⟨t', by omega⟩) := by - show ((strandBundle (t' + 1)).disjUnion F).boundaryFlag + 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⟩) = @@ -332,9 +332,9 @@ noncomputable def stageStepFlagEquiv (t t' u : ℕ) (ht : t' + 1 ≤ t) · -- f = Sum.inl (⟨k, hk⟩, b) dsimp only by_cases hlt : k < t' - · simp only [dif_pos hlt] + · simp only [dite_eq_left hlt] · have hk_eq : k = t' := by omega - simp only [dif_neg hlt] + simp only [dite_eq_right hlt] have hb : b = false := by by_contra hbt have hbtrue : b = true := by cases b <;> simp_all @@ -351,19 +351,19 @@ noncomputable def stageStepFlagEquiv (t t' u : ℕ) (ht : t' + 1 ≤ t) exact hne.2 (by rw [stageStep_rightBoundary] exact congrArg Sum.inr heq) - simp only [dif_neg hg] + simp only [dite_eq_right hg] right_inv y := by match y with | Sum.inl (⟨k, hk⟩, b) => dsimp only - simp only [dif_pos hk] + simp only [dite_eq_left hk] | Sum.inr g => dsimp only by_cases hg : g = F.boundaryFlag ⟨t', by omega⟩ - · simp only [dif_pos hg, dif_neg (show ¬ (t' : ℕ) < t' from Nat.lt_irrefl + · 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 [dif_neg hg] + · simp only [dite_eq_right hg] /-! ### interfaceStepEquiv evaluation lemmas -/ @@ -398,7 +398,7 @@ private theorem interfaceStepEquiv_symm_inr_below (s t u : ℕ) (j : Fin (t + u) simp only [finRemoveEquiv, Equiv.coe_fn_symm_mk] rw [finSuccEquiv'_symm_some_below] · simp [Fin.castSucc] - · simp [Fin.lt_def, Fin.castSucc]; exact hj + · simp? [Fin.lt_def, Fin.castSucc]; exact hj private theorem interfaceStepEquiv_symm_inr_above (s t u : ℕ) (j : Fin (t + u)) (hj : ¬ j.val < t) : @@ -424,7 +424,7 @@ theorem interfaceStepEquiv_eval_inl (s t u : ℕ) (j : ℕ) (hj : j < s + t) : fun h => by simp [Fin.ext_iff] at h; omega, fun h => by simp at h⟩ = Sum.inl ⟨j, hj⟩ := by - rw [Equiv.apply_eq_iff_eq_symm_apply] + 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 @@ -435,7 +435,7 @@ theorem interfaceStepEquiv_eval_inr_below (s t u : ℕ) (j : ℕ) (hj : j < t) : fun h => by simp at h, fun h => by simp [Fin.ext_iff] at h; omega⟩ = Sum.inr ⟨j, by omega⟩ := by - rw [Equiv.apply_eq_iff_eq_symm_apply] + apply (Equiv.eq_symm_apply _).mp exact Subtype.ext (interfaceStepEquiv_symm_inr_below s t u ⟨j, by omega⟩ hj).symm @@ -456,7 +456,7 @@ theorem interfaceStepEquiv_eval_inr_above (s t u : ℕ) (j : ℕ) 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.apply_eq_iff_eq_symm_apply _).mpr key.symm + exact (Equiv.eq_symm_apply _).mp key.symm /-! ### The stage step equivalence -/ @@ -476,508 +476,536 @@ private noncomputable abbrev sourceFragment (t t' u : ℕ) (ht : t' + 1 ≤ t) -- Raised budget: the four equivalence fields are checked against -- the glued fragment at once, each on both label halves. -/-- 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. -/ -private 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 - · -- ═══════ CASE: strand flag (⟨k, hk⟩, b) ═══════ - 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, dif_pos hlt] +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 ⟨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)) = + (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.inl (⟨k, hlt⟩, - b))).map id - (stageEquiv t t' u _) = _ - change (((strandBundle t').attach (⟨k, hlt⟩, b)).map Sum.inl - Sum.inl).map id + change (((strandBundle t').disjUnion F).attach (Sum.inr g)).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⟩, dif_pos hlt] - · simp only [ite_true] - rw [stageEquiv_inl t t' u (by omega) ⟨t' + k, by omega⟩, - dif_neg (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⟩ = + 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.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 + ⟨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) = _ - 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⟩, - dif_pos (show (k : ℕ) < t' + 1 from by omega)] - · simp only [ite_true] - rw [stageEquiv_inl t (t' + 1) u ht ⟨(t' + 1) + k, by omega⟩, - dif_neg (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, dif_neg 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⟩, - dif_neg (show ¬ (t' : ℕ) < t' from Nat.lt_irrefl t'), - dif_pos (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 + change ((F.attach g).map Sum.inr Sum.inr).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⟩, - dif_pos (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₂⟩ := ℓ + 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 ⟨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 - · -- ═══════ CASE 3: F-flag g ═══════ - 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) + 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.inl (Sum.inr v) - have hLHS : (targetFragment t t' u (by omega) F).attach (Sum.inr g) = + (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]; rfl + 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.inl (Sum.inr v) := by + 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]; rfl + 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ℓ' => ?_) - · simp only [Sum.map_inl, id_eq] - exact congrArg Sum.inl (Sum.inl.inj (hv'.symm.trans hba)) + · exact absurd (hv'.symm.trans hba) (nomatch ·) · obtain ⟨ℓ', _hs₁, _hs₂⟩ := ℓ' - exact absurd (hℓ'.symm.trans hba) (nomatch ·) - exact (hflag ▸ hLHS).trans + 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 - · -- 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) ℓ, dif_pos 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 ℓ, - dif_pos (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) ℓ, - dif_neg (show ¬ ℓ.val < t' from hℓ_lt_t'), dif_pos 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 ℓ, - dif_neg (show ¬ ℓ.val < t' + 1 from by omega), dif_pos - 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) ℓ, - dif_neg (show ¬ ℓ.val < t' from hℓ_lt_t'), dif_neg 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 ℓ, - dif_neg (show ¬ ℓ.val < t' + 1 from by omega), dif_neg - 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 - pairing_comm := fun f => by - obtain ⟨fval, hne⟩ := f - show (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 [dif_neg hni, dif_neg 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, dif_pos 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, dif_pos 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, dif_pos 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, dif_neg 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) ≠ + +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 - 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 [dif_neg hni, dif_pos hnj] - show (baseFragment t t' u ht F).pairing - ((baseFragment t t' u ht F).boundaryFlag - (Sum.inl ⟨t + t', by omega⟩)) = _ + 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 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 + 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]; 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⟩ := + · 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 - 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, dif_neg (Nat.lt_irrefl t')] - rw [hflag_rw, hflag_f] - show 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 [dif_neg hni, dif_neg 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 + 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. -/ +private 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 := 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)) : @@ -1005,7 +1033,7 @@ def Fragment.Equiv.relabelPointwiseId (W : Fragment α) (e : α ≃ α) flagEquiv := _root_.Equiv.refl _ vertexEquiv := _root_.Equiv.refl _ attach_comm := fun f => by - show W.attach f = ((W.attach f).map id e).map (_root_.Equiv.refl _) id + change W.attach f = ((W.attach f).map id e).map (_root_.Equiv.refl _) id rcases W.attach f with v | ℓ · simp · simp [h ℓ] @@ -1021,7 +1049,7 @@ private theorem baseFragment_gluePair_eq (t t' u : ℕ) (ht : t' + 1 ≤ t) (baseFragment t t' u ht F).gluePairOpen (Sum.inl ⟨t + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) (by simp) (stageStep_hopen t t' u ht F) := by unfold Fragment.gluePair - exact dif_neg (stageStep_hopen t t' u ht F) + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLawRight.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLawRight.lean index 5a8a7ac33c..0ed07b45d1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLawRight.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLawRight.lean @@ -58,24 +58,24 @@ def stageEquivR (s t' u : ℕ) (ht : t' ≤ u) : · -- Sum.inl ℓ simp only by_cases h : ℓ.val < s + t' - · rw [dif_pos h] + · rw [dite_eq_left h] · simp only - [dif_neg h, dif_neg (show ¬ (t' + (ℓ.val - s) < t' + t') from by omega)] + [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 [dif_pos a.isLt] + rw [dite_eq_left a.isLt] right_inv y := by rcases y with j | k · -- Sum.inl j simp only - rw [dif_pos j.isLt] + rw [dite_eq_left j.isLt] · -- Sum.inr k simp only by_cases h : k.val < t' + t' - · rw [dif_pos h] + · rw [dite_eq_left h] · simp only - [dif_neg h, dif_neg (show ¬ (s + (k.val - t') < s + t') from by omega)] + [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 -/ @@ -106,8 +106,8 @@ theorem stageEquivR_zero_inl (s u : ℕ) (ℓ : Fin (s + u)) : else Sum.inr ⟨ℓ.val - s, by omega⟩ := by rw [stageEquivR_inl] by_cases h : ℓ.val < s - · rw [dif_pos (show ℓ.val < s + 0 from by omega), dif_pos h] - · rw [dif_neg (show ¬ ℓ.val < s + 0 from by omega), dif_neg h] + · 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 @@ -122,12 +122,12 @@ noncomputable def stageZeroEquivR (s u : ℕ) (F : Fragment (Fin (s + u))) : attach_comm f := by rcases f with g | ⟨⟨k, hk⟩, _⟩ · -- inl g (F-flag) - show F.attach ((Equiv.sumEmpty _ _) (Sum.inl g)) = + 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] - show F.attach g = + 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)) @@ -162,13 +162,13 @@ theorem stageStepR_leftBoundary (s t' u : ℕ) (ht : t' + 1 ≤ u) (stageEquivR s (t' + 1) u ht)).boundaryFlag (Sum.inl ⟨s + t', by omega⟩) = Sum.inl (F.boundaryFlag ⟨s + t', by omega⟩) := by - show (F.disjUnion (strandBundle (t' + 1))).boundaryFlag + 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 [dif_pos (show (s + t' : ℕ) < s + (t' + 1) from by omega)] + rw [dite_eq_left (show (s + t' : ℕ) < s + (t' + 1) from by omega)] rw [hsymm] rfl @@ -180,7 +180,7 @@ theorem stageStepR_rightBoundary (s t' u : ℕ) (ht : t' + 1 ≤ u) (stageEquivR s (t' + 1) u ht)).boundaryFlag (Sum.inr ⟨t', by omega⟩) = Sum.inr (⟨t', by omega⟩, false) := by - show (F.disjUnion (strandBundle (t' + 1))).boundaryFlag + 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⟩) = @@ -264,10 +264,10 @@ noncomputable def stageStepFlagEquivR (s t' u : ℕ) (ht : t' + 1 ≤ u) exact hne.1 (by rw [stageStepR_leftBoundary] exact congrArg Sum.inl heq) - simp only [dif_neg hg] + simp only [dite_eq_right hg] · -- f = Sum.inr (⟨k, hk⟩, b) by_cases hlt : k < t' - · simp only [dif_pos hlt] + · simp only [dite_eq_left hlt] · have hk_eq : k = t' := by omega have hb : b = true := by by_contra hbf @@ -276,7 +276,7 @@ noncomputable def stageStepFlagEquivR (s t' u : ℕ) (ht : t' + 1 ≤ u) rw [stageStepR_rightBoundary] exact hk_eq ▸ hbfalse ▸ congrArg Sum.inr (Prod.ext (Fin.ext rfl) rfl)) - simp only [dif_neg hlt, + simp only [dite_eq_right hlt, show F.boundaryFlag ⟨s + t', by omega⟩ = F.boundaryFlag ⟨s + t', by omega⟩ from rfl, dite_true] @@ -287,12 +287,12 @@ noncomputable def stageStepFlagEquivR (s t' u : ℕ) (ht : t' + 1 ≤ u) | Sum.inl g => dsimp only by_cases hg : g = F.boundaryFlag ⟨s + t', by omega⟩ - · simp only [dif_pos hg, dif_neg (show ¬ (t' : ℕ) < t' from Nat.lt_irrefl + · 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 [dif_neg hg] + · simp only [dite_eq_right hg] | Sum.inr (⟨k, hk⟩, b) => - simp only [dif_pos hk] + simp only [dite_eq_left hk] /-! ### The stage step equivalence -/ @@ -311,7 +311,496 @@ private noncomputable abbrev sourceFragmentR (s t' u : ℕ) (ht : t' + 1 ≤ u) (by simp) (stageStepR_hopen s t' u ht F)).relabel (interfaceStepEquiv s t' u) --- Raised budget: as for the left-hand step. +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. -/ @@ -325,461 +814,13 @@ private noncomputable def stageStepEquivR (s t' u : ℕ) (ht : t' + 1 ≤ u) attach_comm f := by obtain ⟨fval, hne⟩ := f rcases fval with g | ⟨⟨k, hk⟩, b⟩ - · -- ═══════ CASE: F-flag g ═══════ - 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, dif_pos 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, - dif_pos (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, dif_neg (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, - dif_neg (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 - · -- ═══════ CASE: strand flag (⟨k, hk⟩, b) ═══════ - 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, dif_pos 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, dif_neg 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, - dif_neg (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 + · 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 - show (stageStepFlagEquivR s t' u ht F) - (Fragment.rewire (stageStepR_hopen s t' u ht F) ⟨fval, hne⟩) = - (targetFragmentR s t' u (by omega) F).pairing - ((stageStepFlagEquivR s t' u ht F) ⟨fval, hne⟩) rcases fval with g | ⟨⟨k, hk⟩, b⟩ - · -- ═══════ CASE: F-flag g ═══════ - 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, dif_pos hpi] - show (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, dif_neg (Nat.lt_irrefl t')] - rw [hflag_rw, hflag_f] - show 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 [dif_neg hni, dif_neg 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 - · -- ═══════ CASE: strand flag (⟨k, hk⟩, b) ═══════ - 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 [dif_neg hni, dif_neg 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, dif_pos 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, dif_pos 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, dif_neg hni, dif_pos hpair_eq_bdy] - show (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, dif_neg hlt] - rw [hflag_rw, hflag_f] - rfl + · 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 -/ @@ -788,7 +829,7 @@ 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, dif_pos ℓ.isLt] + · rw [stageEquivR_inl, dite_eq_left ℓ.isLt] · rw [stageEquivR_inr] /-- In the base fragment, the glue is always open, so `gluePair` @@ -800,7 +841,7 @@ private theorem baseFragmentR_gluePair_eq (s t' u : ℕ) (ht : t' + 1 ≤ u) (baseFragmentR s t' u ht F).gluePairOpen (Sum.inl ⟨s + t', by omega⟩) (Sum.inr ⟨t', by omega⟩) (by simp) (stageStepR_hopen s t' u ht F) := by unfold Fragment.gluePair - exact dif_neg (stageStepR_hopen s t' u ht F) + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceAlternate.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceAlternate.lean index 3b36da3d06..8b8a33b8e1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceAlternate.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceAlternate.lean @@ -26,8 +26,7 @@ namespace RS namespace EdgeSubset -open Fragment Classical - +open Fragment section OpenCut variable {L : Type} @@ -76,7 +75,7 @@ theorem chainDir_unglueOpen_alternates (partnerSurvJ hopen).prop.2 have hflip := o'.pairing_flip (partnerSurvI hopen) hIg hJg rw [gluePairOpen_partnerSurvI hij hopen] at hflip - show unglueIsOut o'.isOut (V.pairing (V.boundaryFlag j)) + 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, @@ -130,7 +129,7 @@ theorem chainDir_unglueOpen_surviving = V.pairing (V.boundaryFlag b.val) := gluePairOpen_pairing_val_of_ne hij hopen (glueBoundaryFlag V i j b) hne1 hne2 - show unglueIsOut o'.isOut (V.pairing (V.boundaryFlag b.val)) + 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) @@ -206,7 +205,7 @@ theorem chainDir_unglueClosed_surviving {V : Fragment L} {i : L} {j : L} (V.boundaryFlag bl.val) = chainDir o' ((V.gluePairClosed i j hclosed).boundaryFlag bl) := by - show unglueIsOut o'.isOut (V.pairing (V.boundaryFlag bl.val)) + 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) @@ -355,7 +354,7 @@ 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 - show interfaceStepEquiv 0 n 0 + 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)] @@ -368,7 +367,7 @@ 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 - show interfaceStepEquiv 0 n 0 + 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)] @@ -376,7 +375,7 @@ theorem interfaceStepEquiv_intR (n : ℕ) (b : Fin n) : rw [rightRemoveEquiv_val] have := b.isLt simp only [Fin.val_cast, Fin.val_castSucc] - rw [if_pos (by omega)] + rw [ite_eq_left (by omega)] /-! ## The subsets the composition reaches @@ -445,7 +444,7 @@ theorem reachable_succ_open (n : ℕ) (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 [dif_neg hop] at hr' + rwa [dite_eq_right hop] at hr' open Classical in /-- The reach, one stage down, at a closing cut. -/ @@ -461,7 +460,7 @@ theorem reachable_succ_closed (n : ℕ) (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 [dif_pos hcl] at hr' + rwa [dite_eq_left hcl] at hr' open Classical in /-- **The stage's own cut alternates.** For a reached subset the @@ -513,7 +512,7 @@ theorem chainDir_stepDataDown_top (n : ℕ) (dataOfEq (gluePair_eq_open n V hop) (stepDataGlued n V 𝒟step)) := by unfold stepDataDown - rw [dif_neg hop] + rw [dite_eq_right hop] have hIl' : (partnerSurvI hop).val ∈ (EdgeSubset.mk (liftSubsetOpen hop (V.dropSubset (cutL n) (cutR n) s)) hcL : @@ -598,7 +597,7 @@ theorem chainDir_stepDataDown_lower_open (n : ℕ) (dataOfEq (gluePair_eq_open n V hop) (stepDataGlued n V 𝒟step)) := by unfold stepDataDown - rw [dif_neg hop] + 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] @@ -664,7 +663,7 @@ theorem chainDir_stepDataDown_lower_closed (n : ℕ) (dataOfEq (gluePair_eq_closed n V hcl) (stepDataGlued n V 𝒟step)) := by unfold stepDataDown - rw [dif_pos hcl] + 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 @@ -674,7 +673,7 @@ theorem chainDir_stepDataDown_lower_closed (n : ℕ) halt /-- A boundary flag is never internal. -/ -theorem boundaryFlag_not_internal {L' : Type} [LinearOrder L'] +theorem boundaryFlag_not_internal {L' : Type} {W : Fragment L'} (F : EdgeSubset W) (b : L') : W.boundaryFlag b ∉ F.internalFlags := by intro hx diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceContract.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceContract.lean index 55334d8634..ea838423d5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceContract.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceContract.lean @@ -28,8 +28,7 @@ namespace RS namespace EdgeSubset -open Fragment Equiv Classical - +open Fragment Equiv /-- The lexicographic order on the recursion's label type. -/ @[reducible] local instance contractOrder (n : ℕ) : LinearOrder (Fin (0 + n) ⊕ Fin (n + 0)) := @@ -160,7 +159,7 @@ theorem unglueDataOpen_apply (𝒟' t hct hEt hnet).1 (𝒟' t hct hEt hnet).2)⟩ := by subst hdrop unfold unglueDataOpen - rw [dif_pos hct] + rw [dite_eq_left hct] end UnglueData diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceCut.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceCut.lean index 0d3b7f6a35..d5d4a5a5f3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceCut.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceCut.lean @@ -31,8 +31,7 @@ namespace RS namespace EdgeSubset -open Fragment Equiv Classical - +open Fragment Equiv section InterfaceCut variable {γ δ : Type} @@ -222,7 +221,7 @@ theorem interfaceCut_relabelUp_edge (((interfaceCut (F.relabelUp E.toEquiv) e' hp').map (usedLabRelabelEquiv E F)).edge x).val = E.symm (interfaceSwap e' (E x.val)) := by - show E.symm ((interfaceCut (F.relabelUp E.toEquiv) e' hp').edge + change E.symm ((interfaceCut (F.relabelUp E.toEquiv) e' hp').edge ⟨E x.val, _⟩).val = _ rw [interfaceCut_edge_val] @@ -305,7 +304,7 @@ theorem interfaceSwap_interfaceStep (n : ℕ) hy.1 (congrArg Sum.inl (Fin.ext hh)) have h2 : (v : ℕ) < 0 + n + 1 := v.isLt omega - show Sum.inr (((rightRemoveEquiv n 0).symm + 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) @@ -333,7 +332,7 @@ theorem interfaceSwap_interfaceStep (n : ℕ) hy.2 (congrArg Sum.inr (Fin.ext hh)) have h2 : (w : ℕ) < n + 1 + 0 := w.isLt omega - show Sum.inl (((finRemoveEquiv ⟨0 + n, Nat.lt_succ_self _⟩).symm + 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) @@ -343,8 +342,8 @@ theorem interfaceSwap_interfaceStep (n : ℕ) have hcw : (c : ℕ) = (w : ℕ) := by have h := rightRemoveEquiv_val n 0 ⟨w, fun he => hy.2 (congrArg Sum.inr he)⟩ - rw [if_pos hw] at h - show ((rightRemoveEquiv n 0 + 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 @@ -368,7 +367,7 @@ theorem interfaceSwap_cut (n : ℕ) : (Sum.inl ⟨0 + n, Nat.lt_succ_self _⟩) = Sum.inr (⟨n, by omega⟩ : Fin (n + 1 + 0)) := by refine congrArg Sum.inr (Fin.ext ?_) - show (0 + n : ℕ) = n + change (0 + n : ℕ) = n omega end InterfaceStep @@ -421,7 +420,7 @@ theorem throughValueC_isEmpty [LinearOrder L] [IsEmpty L] {V : Fragment L} = F.throughSummand h st hbnd (Classical.choice hne).2.val ((Classical.choice hne).1.openCircuitCount) := by unfold EdgeSubset.throughValueC - rw [dif_pos hne, pathSign_isEmpty, one_mul] + rw [dite_eq_left hne, pathSign_isEmpty, one_mul] open Classical in /-- **The closed top's partition value is a sum of RS21's @@ -449,20 +448,20 @@ theorem throughMixedPartitionC_isEmpty unfold throughMixedPartitionC refine congrArg₂ (· * ·) rfl (Finset.sum_congr rfl (fun s _ => ?_)) by_cases hc : ∀ f ∈ s, V.pairing f ∈ s - · rw [dif_pos hc, dif_pos hc] + · rw [dite_eq_left hc, dite_eq_left hc] by_cases hbnd : genBoundarySubsetMatches V s st - · rw [dif_pos hbnd, dif_pos hbnd] + · rw [dite_eq_left hbnd, dite_eq_left hbnd] by_cases hE : (EdgeSubset.mk s hc).Eulerian - · rw [if_pos hE, if_pos hE] + · rw [ite_eq_left hE, ite_eq_left hE] by_cases hne : Nonempty (EdgeSubset.mk s hc).CanonData - · rw [dif_pos hne] + · rw [dite_eq_left hne] exact throughValueC_isEmpty _ h st hbnd hne - · rw [dif_neg hne] + · rw [dite_eq_right hne] unfold EdgeSubset.throughValueC - rw [dif_neg hne] - · rw [if_neg hE, if_neg hE] - · rw [dif_neg hbnd, dif_neg hbnd] - · rw [dif_neg hc, dif_neg hc] + 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} @@ -527,7 +526,7 @@ theorem chordInv_prodRel_inl inl_mem_boundary.mp hb refine (W₁.disjUnion W₂).boundaryFlag_injective ?_ rw [boundaryFlag_chordInv F (prodRel κ₁ κ₂) hb] - show (prodRel κ₁ κ₂).pathMatch (Sum.inl (W₁.boundaryFlag a)) 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'] @@ -546,7 +545,7 @@ theorem chordInv_prodRel_inr inr_mem_boundary.mp hb refine (W₁.disjUnion W₂).boundaryFlag_injective ?_ rw [boundaryFlag_chordInv F (prodRel κ₁ κ₂) hb] - show (prodRel κ₁ κ₂).pathMatch (Sum.inr (W₂.boundaryFlag b)) 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'] @@ -574,7 +573,7 @@ theorem cutMatching_disjUnion_edge rw [← chordInv_prodRel_inl F κ₁ κ₂ hb] exact chordInv_mem F (prodRel κ₁ κ₂) hb⟩ := Subtype.ext (chordInv_prodRel_inl F κ₁ κ₂ hb) - show usedDisjUnionEquiv F ((cutMatching F (prodRel κ₁ κ₂) + change usedDisjUnionEquiv F ((cutMatching F (prodRel κ₁ κ₂) (prodOrient o₁ o₂)).edge ((usedDisjUnionEquiv F).symm (Sum.inl a))) = _ rw [hy] @@ -588,7 +587,7 @@ theorem cutMatching_disjUnion_edge rw [← chordInv_prodRel_inr F κ₁ κ₂ hb] exact chordInv_mem F (prodRel κ₁ κ₂) hb⟩ := Subtype.ext (chordInv_prodRel_inr F κ₁ κ₂ hb) - show usedDisjUnionEquiv F ((cutMatching F (prodRel κ₁ κ₂) + change usedDisjUnionEquiv F ((cutMatching F (prodRel κ₁ κ₂) (prodOrient o₁ o₂)).edge ((usedDisjUnionEquiv F).symm (Sum.inr b))) = _ rw [hy] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceOrderIso.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceOrderIso.lean index 432add2f0a..de1f2f4fd7 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceOrderIso.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceOrderIso.lean @@ -138,7 +138,7 @@ theorem finSumFinEquiv_strictMono (m n : ℕ) : | inr b => rw [finSumFinEquiv_apply_left, finSumFinEquiv_apply_right] have ha : (a : ℕ) < m := a.isLt - show (a : ℕ) < m + (b : ℕ) + change (a : ℕ) < m + (b : ℕ) omega | inr b => cases y with @@ -171,7 +171,7 @@ shifts indices up without reordering them. -/ theorem finRemoveEquiv_symm_strictMono {n : ℕ} (a : Fin (n + 1)) : StrictMono (finRemoveEquiv a).symm := by intro y y' h - show a.succAbove y < a.succAbove y' + change a.succAbove y < a.succAbove y' exact Fin.strictMono_succAbove a h /-- Hence removing a point is too. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceShift.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceShift.lean index b0589a75be..db4431b1ca 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceShift.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceShift.lean @@ -94,7 +94,7 @@ private theorem shift_ground_left_aux (s : ℕ) {t : ℕ} simp only [List.map_cons, Fragment.mapPairs, Prod.map] refine congrArg₂ List.cons (Prod.ext ?_ rfl) (shift_ground_left_aux s σ u l) - show Sum.inl ((outPermEquiv s σ).symm ⟨s + k.val, _⟩) = _ + change Sum.inl ((outPermEquiv s σ).symm ⟨s + k.val, _⟩) = _ exact congrArg Sum.inl ((congrArg (outPermEquiv s σ).symm (show (⟨s + k.val, _⟩ : Fin (s + t)) = @@ -122,7 +122,7 @@ private theorem shift_ground_right_aux (s : ℕ) {t : ℕ} simp only [List.map_cons, Fragment.mapPairs, Prod.map] refine congrArg₂ List.cons (Prod.ext rfl ?_) (shift_ground_right_aux s σ u l) - show Sum.inr ((inPermEquiv σ.symm u).symm ⟨k.val, _⟩) = _ + change Sum.inr ((inPermEquiv σ.symm u).symm ⟨k.val, _⟩) = _ exact congrArg Sum.inr ((congrArg (inPermEquiv σ.symm u).symm (show (⟨k.val, _⟩ : Fin (t + u)) = @@ -396,7 +396,7 @@ theorem shiftLabel_meet (s : ℕ) {t : ℕ} (σ : Equiv.Perm (Fin t)) rcases xv with a | b · rcases Nat.lt_or_ge a.val s with ha | ha · refine Fin.ext ?_ - show ((outPermEquiv s σ) a).val = a.val + 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 @@ -426,7 +426,7 @@ theorem shiftLabel_meet (s : ℕ) {t : ℕ} (σ : Equiv.Perm (Fin t)) ((inPermEquiv_high σ.symm u ⟨b.val - t, hk⟩).trans (Fin.ext (show t + (b.val - t) = b.val by omega)))) refine Fin.ext ?_ - show s + (b.val - t) = + change s + (b.val - t) = s + (((inPermEquiv σ.symm u) b).val - t) have := congrArg Fin.val hv omega diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LabelChords.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LabelChords.lean index b55d11dad7..4149023799 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LabelChords.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LabelChords.lean @@ -18,7 +18,7 @@ index over which the pairing-resolved open-sector values live. namespace RS -open scoped Classical + variable {α : Type} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerCast.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerCast.lean index 4ffa030315..bb8b151d83 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerCast.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerCast.lean @@ -24,8 +24,7 @@ namespace RS namespace EdgeSubset -open Fragment Equiv Classical - +open Fragment Equiv section SubsetEq variable {β : Type} @@ -47,7 +46,6 @@ def orientOfEq change its circuit count. -/ theorem openCircuitCount_relOfEq {V : Fragment β} {F : EdgeSubset V} {F' : EdgeSubset V} (hF : F = F') - [Fintype β] (κ : F.RelTransitionSystem) : (relOfEq hF κ).openCircuitCount = κ.openCircuitCount := by subst hF; rfl diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean index 6ea58db3bb..d772c59b0b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean @@ -25,8 +25,7 @@ namespace RS namespace EdgeSubset -open Fragment Equiv Classical - +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. -/ @@ -392,7 +391,7 @@ theorem stepData_eq_closed (n : ℕ) (gluePair_eq_closed (cutL_ne_cutR n) hcl).symm) (stepDataClosed n V D hcl) := by unfold stepData - rw [dif_pos hcl] + rw [dite_eq_left hcl] open Classical in /-- On an open cut the step is the open branch, transported. -/ @@ -407,7 +406,7 @@ theorem stepData_eq_open (n : ℕ) (gluePair_eq_open (cutL_ne_cutR n) hop).symm) (stepDataOpen n V D hop) := by unfold stepData - rw [dif_neg hop] + rw [dite_eq_right hop] /-! ## One stage of the ledger @@ -511,7 +510,7 @@ theorem ledger_glueData : ∀ (n : ℕ) (F : EdgeSubset W) (M N : DirMatching (UsedLab F)), DirMatching.unionCount M N = 0 := by intro W F M N - haveI : IsEmpty (UsedLab F) := ⟨fun x => isEmptyElim x.val⟩ + have : IsEmpty (UsedLab F) := ⟨fun x => isEmptyElim x.val⟩ exact DirMatching.unionCount_of_isEmpty M N simp only [glueCount, stageLedger, ledgerOf, glueData, hzero, Nat.add_zero] @@ -537,11 +536,11 @@ theorem ledger_glueData : ∀ (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 [if_pos ⟨hcl, hb⟩, if_pos hb] - · rw [if_neg (fun h => hb h.2), if_neg hb]] + · 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, - if_neg (fun h => hcl h.1), Nat.add_zero] + 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 @@ -561,7 +560,7 @@ theorem ledgerOf_isEmpty {V : Fragment (Fin (0 + 0) ⊕ Fin (0 + 0))} (hp : SwapPaired F (interfaceSwap (stepIdent 0))) (κ : F.RelTransitionSystem) : ledgerOf F hp κ = κ.openCircuitCount := by - haveI : IsEmpty (UsedLab F) := ⟨fun x => isEmptyElim x.val⟩ + have : IsEmpty (UsedLab F) := ⟨fun x => isEmptyElim x.val⟩ rw [ledgerOf, DirMatching.unionCount_of_isEmpty, Nat.add_zero] /-- **RS21's (14).** The composed system's circuit count, plus one @@ -600,7 +599,7 @@ 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 - show V.circles = V.circles + 0 + change V.circles = V.circles + 0 omega | n + 1, V => by have ih := circles_glueInterface n @@ -611,18 +610,18 @@ theorem circles_glueInterface : ∀ (n : ℕ) (interfaceStepEquiv 0 n 0)).circles = V.circles + (if V.pairing (V.boundaryFlag (cutL n)) = V.boundaryFlag (cutR n) then 1 else 0) := by - show (V.gluePair (cutL n) (cutR n) (cutL_ne_cutR n)).circles = _ + 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 [dif_pos hcl, if_pos hcl] + · rw [dite_eq_left hcl, ite_eq_left hcl] rfl - · rw [dif_neg hcl, if_neg hcl] - show V.circles = V.circles + 0 + · rw [dite_eq_right hcl, ite_eq_right hcl] + change V.circles = V.circles + 0 omega - show (glueInterface 0 n 0 _).circles = _ + change (glueInterface 0 n 0 _).circles = _ rw [ih, hstep] - show _ = V.circles + ((if V.pairing (V.boundaryFlag (cutL n)) + change _ = V.circles + ((if V.pairing (V.boundaryFlag (cutL n)) = V.boundaryFlag (cutR n) then 1 else 0) + _) omega diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean index ff2e504409..3e7a188149 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean @@ -27,7 +27,7 @@ and vanishes on a pairing-preserving one namespace RS -open scoped Classical + section PairSets diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerStage.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerStage.lean index 4fe38f810a..748a0c9179 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerStage.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerStage.lean @@ -22,8 +22,7 @@ namespace RS namespace EdgeSubset -open Fragment Equiv Classical - +open Fragment Equiv section StageOpen variable {α : Type} {W : Fragment α} @@ -365,11 +364,11 @@ theorem ledgerStage_closed_bit + DirMatching.unionCount (cutMatching (Flb) κ o) N := by cases b with | false => - rw [if_neg (by decide : ¬ (false = true)), Nat.add_zero] + 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 [if_pos rfl] + 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)) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerValue.lean index b78cac40bf..c7b79ec3c4 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerValue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerValue.lean @@ -21,7 +21,7 @@ the paired step in value form. namespace RS -open scoped Classical + /-- **The paired step, value form**: across a π-returning repair block, canonical-orientation existence transfers and the diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopExample.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopExample.lean index 1117b0b1f8..ee4229d148 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopExample.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopExample.lean @@ -125,7 +125,7 @@ private def loopFullOrientation : loopFullTransition.Orientation where /-- Nothing participates, so there are no circuits. -/ private theorem circuitCount_loopEmpty : loopEmptyTransition.circuitCount = 0 := by - haveI : IsEmpty {f : loopGraph.Flag // f ∈ loopEmpty.flags} := + 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, @@ -246,7 +246,7 @@ private theorem eulerian_loopEmpty : loopEmpty.Eulerian := by vertex, which therefore has degree two. -/ private theorem eulerian_loopFull : loopFull.Eulerian := by intro v - letI := Classical.decEq (loopGraph.Vertex ⊕ Fin 0) + 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), @@ -284,8 +284,8 @@ private theorem evenColoursAt_loopEmpty (ψ : loopEmpty.EvenColouring 2) /-- No flag participates, so no flag is incoming. -/ private theorem inFlagsAt_loopEmpty (v : loopGraph.Vertex) : loopEmpty.inFlagsAt loopEmptyOrientation v = [] := by - letI := loopGraph.flagOrder - letI := Classical.dec + let := loopGraph.flagOrder + let := Classical.dec unfold EdgeSubset.inFlagsAt rw [show loopEmpty.flags = ∅ from rfl, Finset.filter_empty, Finset.sort_empty] @@ -342,8 +342,8 @@ 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 - letI := loopGraph.flagOrder - letI := Classical.dec + let := loopGraph.flagOrder + let := Classical.dec have hfilter : Finset.filter (fun f => loopGraph.attach f = Sum.inl v ∧ loopFullOrientation.isOut f = false) loopFull.flags = @@ -352,7 +352,7 @@ private theorem inFlagsAt_loopFull (v : loopGraph.Vertex) : simp only [Finset.mem_filter, Finset.mem_singleton, show loopFull.flags = Finset.univ from rfl, Finset.mem_univ, true_and] - show (loopGraph.attach f = Sum.inl v ∧ f = loopIn) ↔ f = loopIn + 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] @@ -380,7 +380,7 @@ 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 - haveI : IsEmpty {f : loopGraph.Flag // f ∉ loopFull.flags} := + 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] @@ -455,18 +455,18 @@ theorem mixedPartition_loopGraph (θ : ℂ) : 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 => dif_neg (loop_pairing_not_closed x + (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, - dif_pos loopEmpty_closed, dif_pos loopFull_closed] - show (if loopEmpty.Eulerian then + 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 [if_pos eulerian_loopEmpty, if_pos eulerian_loopFull, + rw [ite_eq_left eulerian_loopEmpty, ite_eq_left eulerian_loopFull, mixedValue_loopEmpty, mixedValue_loopFull] ring diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopVerify.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopVerify.lean index aa0d8386de..713c1eff09 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopVerify.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopVerify.lean @@ -79,7 +79,7 @@ theorem lvThroughSummand (hM : MixedFunctional 0 4) unfold EdgeSubset.throughSummand rw [cThroughProduct, pow_zero, one_mul, one_mul] rw [Fintype.sum_subsingleton _ cPsi] - rw [if_pos cEvenMatch] + rw [ite_eq_left cEvenMatch] have hzero : ∀ φ : cSubset.CoreOddColouring 4, φ ≠ cPhi → (if cSubset.coreOddBoundaryMatch cState φ then ∏ v : cFragment.Vertex, @@ -92,9 +92,9 @@ theorem lvThroughSummand (hM : MixedFunctional 0 4) rcases Classical.em (cSubset.coreOddBoundaryMatch cState φ) with hb | hb · exact absurd (cPhi_unique φ hb) hφ - · rw [if_neg hb] + · rw [ite_eq_right hb] rw [Fintype.sum_eq_single cPhi hzero] - rw [if_pos cOddMatch] + rw [ite_eq_left cOddMatch] rw [Fintype.prod_subsingleton _ cV] rw [cCoreOddSignAt κ o g₁ g₂ hglist, cCoreOddListAt κ o g₁ g₂ hglist] @@ -117,11 +117,11 @@ theorem lvSummand₂flip : oddPartner 4 (cColour 3)] = ([0, 7, 1, 6] : List (Fin (2 * 4))) from by decide, MixedFunctional.evalOdd, - if_pos (by decide : ([0, 7, 1, 6] : List (Fin (2 * 4))).Nodup), + 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, - if_neg (by decide : ¬ ({0, 7, 1, 6} : Finset (Fin (2 * 4))) = + 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, @@ -131,11 +131,11 @@ theorem lvSummand₂flip : oddPartner 4 (cColour 2)] = ([1, 6, 0, 7] : List (Fin (2 * 4))) from by decide, MixedFunctional.evalOdd, - if_pos (by decide : ([1, 6, 0, 7] : List (Fin (2 * 4))).Nodup), + 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, - if_neg (by decide : ¬ ({0, 7, 1, 6} : Finset (Fin (2 * 4))) = + 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] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/MixedPartition.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/MixedPartition.lean index ecc3fd7bbd..02bc7b601b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/MixedPartition.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/MixedPartition.lean @@ -39,7 +39,7 @@ theorem MixedFunctional.evalOdd_swap_adjacent {k ℓ : ℕ} 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 [if_pos hnd', if_pos hnd, sortSign_swap_adjacent l₁ l₂ hab, + 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 @@ -47,7 +47,7 @@ theorem MixedFunctional.evalOdd_swap_adjacent {k ℓ : ℕ} exact hperm.mem_iff] push_cast ring - · rw [if_neg (fun hh => hnd (hperm.nodup_iff.mp hh)), if_neg hnd, + · 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 @@ -68,14 +68,14 @@ theorem MixedFunctional.evalOdd_pair_block_swap {k ℓ : ℕ} simpa using hblocks.append_right l₂ by_cases hnd : (l₁ ++ p₁ :: p₂ :: q₁ :: q₂ :: l₂).Nodup · have hnd' := hperm.nodup_iff.mpr hnd - rw [if_pos hnd', if_pos 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 [if_neg (fun hh => hnd (hperm.nodup_iff.mp hh)), if_neg hnd] + · 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 @@ -130,11 +130,11 @@ theorem oddPartner_invol (ℓ : ℕ) (c : Fin (2 * ℓ)) : oddPartner ℓ (oddPartner ℓ c) = c := by unfold oddPartner by_cases h : c.val < ℓ - · rw [dif_pos h, dif_neg (show ¬ c.val + ℓ < ℓ by omega)] - exact Fin.ext (by show c.val + ℓ - ℓ = c.val; omega) + · 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 [dif_neg h, dif_pos (show c.val - ℓ < ℓ by omega)] - exact Fin.ext (by show c.val - ℓ + ℓ = c.val; omega) + 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. -/ @@ -144,8 +144,8 @@ theorem mem_inFlagsAt_of {α : Type} {W : Fragment α} {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 - letI := W.flagOrder - letI := Classical.dec + let := W.flagOrder + let := Classical.dec unfold EdgeSubset.inFlagsAt rw [Finset.mem_sort, Finset.mem_filter] exact ⟨hmem, hatt, hin⟩ @@ -161,7 +161,7 @@ noncomputable def EdgeSubset.TransitionSystem.Orientation.transport (κ.transport e).Orientation where isOut := fun f => o.isOut (e.flagEquiv.symm f) match_flip := fun f hf => by - show o.isOut (e.flagEquiv.symm + 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) @@ -230,7 +230,7 @@ theorem EdgeSubset.evenColoursAt_transport {W₁ W₂ : Fragment α} rw [Multiset.map_map] congr 1 · funext x - show ψ.val ((EdgeSubset.transportComplEquiv e F).symm + change ψ.val ((EdgeSubset.transportComplEquiv e F).symm ((EdgeSubset.transportComplEquiv e F) x)) = ψ.val x rw [Equiv.symm_apply_apply] · have hfilter : Finset.filter @@ -303,7 +303,7 @@ theorem EdgeSubset.inFlagsAt_transport_perm {W₁ W₂ : Fragment α} · have hcomm := e.attach_comm x rw [hatt] at hcomm simpa using hcomm - · show o.isOut (e.flagEquiv.symm (e.flagEquiv x)) = false + · 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 @@ -314,7 +314,7 @@ theorem EdgeSubset.OddColouring.transport_apply {W₁ W₂ : Fragment α} (hg' : e.flagEquiv g ∈ (EdgeSubset.transport e F).flags) : (EdgeSubset.OddColouring.transport e φ).val ⟨e.flagEquiv g, hg'⟩ = φ.val ⟨g, hg⟩ := by - show φ.val + change φ.val ((EdgeSubset.transportFlagsEquiv e F).symm ⟨e.flagEquiv g, hg'⟩) = _ exact congrArg φ.val (Subtype.ext (Equiv.symm_apply_apply _ _)) @@ -325,7 +325,7 @@ theorem EdgeSubset.TransitionSystem.transport_match (κ : F.TransitionSystem) (g : W₁.Flag) : (κ.transport e).match_ (e.flagEquiv g) = e.flagEquiv (κ.match_ g) := by - show e.flagEquiv (κ.match_ (e.flagEquiv.symm (e.flagEquiv g))) = _ + change e.flagEquiv (κ.match_ (e.flagEquiv.symm (e.flagEquiv g))) = _ rw [Equiv.symm_apply_apply] open Classical in @@ -433,7 +433,7 @@ noncomputable def EdgeSubset.EvenColouring.transportEquiv 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 - show e.flagEquiv (W₁.pairing f.val) = W₂.pairing (e.flagEquiv f.val) + 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 @@ -452,7 +452,7 @@ noncomputable def EdgeSubset.OddColouring.transportEquiv 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 - show e.flagEquiv (W₁.pairing f.val) = W₂.pairing (e.flagEquiv f.val) + 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 @@ -514,12 +514,12 @@ theorem oddPartnerSign_oddPartner (ℓ : ℕ) (i : Fin (2 * ℓ)) : oddPartnerSign ℓ (oddPartner ℓ i) = -oddPartnerSign ℓ i := by unfold oddPartner oddPartnerSign by_cases h : i.val < ℓ - · rw [dif_pos h, if_pos h, - if_neg (show ¬ i.val + ℓ < ℓ by omega)] + · 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 [dif_neg h, if_neg h, - if_pos (show i.val - ℓ < ℓ by omega)] + 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 * ℓ)) : diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalInstance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalInstance.lean index aafb462725..12a42c0edb 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalInstance.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalInstance.lean @@ -35,7 +35,7 @@ theorem tensorMapEquiv_finCongr {n₁ m₁ n₂ m₂ : ℕ} · rw [show x = Fin.natAdd n₁ ⟨x.val - n₁, by have := x.isLt omega⟩ from Fin.ext (by - show x.val = n₁ + (x.val - n₁) + change x.val = n₁ + (x.val - n₁) omega), tensorMapEquiv_natAdd] rfl @@ -62,7 +62,7 @@ variable {R : ℕ} (f : EdgeRankParameter R) noncomputable instance skeinMonoidal : MonoidalCategory (SkeinObj f) where tensorHom_def {X₁ Y₁ X₂ Y₂} p q := by - show HomSpace.tensor f X₁.arity Y₁.arity X₂.arity Y₂.arity + 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) @@ -82,7 +82,7 @@ noncomputable instance skeinMonoidal : leftUnitor_naturality {X Y} p := leftUnitNat_class f p rightUnitor_naturality {X Y} p := rightUnitNat_class f p pentagon W X Y Z := by - show HomSpace.comp f _ _ _ + change HomSpace.comp f _ _ _ (HomSpace.tensor f _ _ _ _ (bundleMapClass f (finCongr _)) (HomSpace.ofFragment f.val (strandBundle Z.arity))) @@ -103,7 +103,7 @@ noncomputable instance skeinMonoidal : exact bundleMapClass_congr f (_root_.Equiv.ext (fun x => Fin.ext rfl)) triangle X Y := by - show HomSpace.comp f _ _ _ + change HomSpace.comp f _ _ _ (bundleMapClass f (finCongr _)) (HomSpace.tensor f _ _ _ _ (HomSpace.ofFragment f.val (strandBundle X.arity)) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalStruct.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalStruct.lean index df856c7dca..6b03b9d9b0 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalStruct.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalStruct.lean @@ -30,7 +30,7 @@ noncomputable def castIso {n m : ℕ} (h : n = m) : hom := bundleMapClass f (finCongr h) inv := bundleMapClass f (finCongr h.symm) hom_inv_id := by - show HomSpace.comp f n m n + change HomSpace.comp f n m n (bundleMapClass f (finCongr h)) (bundleMapClass f (finCongr h.symm)) = HomSpace.ofFragment f.val (strandBundle n) @@ -40,7 +40,7 @@ noncomputable def castIso {n m : ℕ} (h : n = m) : _root_.Equiv.ext (fun x => Fin.ext rfl)] exact bundleMapClass_refl f n inv_hom_id := by - show HomSpace.comp f m n m + change HomSpace.comp f m n m (bundleMapClass f (finCongr h.symm)) (bundleMapClass f (finCongr h)) = HomSpace.ofFragment f.val (strandBundle m) @@ -86,7 +86,7 @@ theorem bundleMapClass_tensor {n₁ m₁ n₂ m₂ : ℕ} theorem skein_tensor_id (X Y : SkeinObj f) : MonoidalCategoryStruct.tensorHom (𝟙 X) (𝟙 Y) = 𝟙 (MonoidalCategoryStruct.tensorObj X Y) := by - show HomSpace.tensor f X.arity X.arity Y.arity Y.arity + 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)) @@ -136,7 +136,7 @@ theorem transposeEquiv_trans_self (a b : ℕ) : · rw [_root_.Equiv.trans_apply, show x = (⟨a + (x.val - a), by have := x.isLt; omega⟩ : Fin (a + b)) from Fin.ext (by - show x.val = a + (x.val - a) + 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) @@ -154,7 +154,7 @@ noncomputable def skeinBraiding (X Y : SkeinObj f) : hom := bundleMapClass f (transposeEquiv X.arity Y.arity) inv := bundleMapClass f (transposeEquiv Y.arity X.arity) hom_inv_id := by - show HomSpace.comp f _ _ _ + change HomSpace.comp f _ _ _ (bundleMapClass f (transposeEquiv X.arity Y.arity)) (bundleMapClass f (transposeEquiv Y.arity X.arity)) = HomSpace.ofFragment f.val @@ -162,7 +162,7 @@ noncomputable def skeinBraiding (X Y : SkeinObj f) : rw [bundleMapClass_comp, transposeEquiv_trans_self] exact bundleMapClass_refl f _ inv_hom_id := by - show HomSpace.comp f _ _ _ + change HomSpace.comp f _ _ _ (bundleMapClass f (transposeEquiv Y.arity X.arity)) (bundleMapClass f (transposeEquiv X.arity Y.arity)) = HomSpace.ofFragment f.val @@ -175,7 +175,7 @@ noncomputable def skeinBraiding (X Y : SkeinObj f) : theorem skeinBraiding_symmetry (X Y : SkeinObj f) : (skeinBraiding f X Y).hom ≫ (skeinBraiding f Y X).hom = 𝟙 (MonoidalCategoryStruct.tensorObj X Y) := by - show HomSpace.comp f _ _ _ + 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)) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/Multiplicativity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/Multiplicativity.lean index e41587add3..c5d6462827 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/Multiplicativity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/Multiplicativity.lean @@ -43,7 +43,7 @@ noncomputable def relabelZeroEquiv (W : Fragment (Fin 0)) 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 - show W.attach f = _ + change W.attach f = _ rw [hval, ha] rfl · exact ℓ.elim0 @@ -64,7 +64,7 @@ noncomputable def composeZeroEquiv (F G : ClosedFragment) : ((Equiv.sumCongr (finCongr (by omega : (0:ℕ) + 0 = 0)) (finCongr (by omega : (0:ℕ) + 0 = 0))).trans finSumFinEquiv) = F.union G := by - haveI : Subsingleton ((Fin ((0:ℕ) + 0) ⊕ Fin ((0:ℕ) + 0)) ≃ Fin ((0:ℕ) + 0)) + have : Subsingleton ((Fin ((0:ℕ) + 0) ⊕ Fin ((0:ℕ) + 0)) ≃ Fin ((0:ℕ) + 0)) := ⟨fun a b => Equiv.ext fun x => isEmptyElim x⟩ rw [he] @@ -84,7 +84,7 @@ noncomputable def unionEmptyLeftEquiv (G : ClosedFragment) : · 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 - show G.attach g = _ + change G.attach g = _ rw [hval, ha] rfl · exact ℓ.elim0 @@ -105,7 +105,7 @@ noncomputable def unionEmptyRightEquiv (W : ClosedFragment) : · 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 - show W.attach g = _ + change W.attach g = _ rw [hval, ha] rfl · exact ℓ.elim0 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/NonSeparatedStep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/NonSeparatedStep.lean index 0c5a89c511..f8fd3bd74b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/NonSeparatedStep.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/NonSeparatedStep.lean @@ -57,7 +57,7 @@ the parity files: namespace RS -open scoped Classical + variable {α : Type} {W : Fragment α} @@ -154,25 +154,25 @@ noncomputable def RelTransitionSystem.Orientation.segFlip by_cases h1 : f = a · subst h1 rw [RelTransitionSystem.repair_match_a hsq, - if_pos hseg.hcS, if_neg hseg.haS, hsame] + ite_eq_left hseg.hcS, ite_eq_right hseg.haS, hsame] by_cases h3 : f = c · subst h3 rw [RelTransitionSystem.repair_match_c hsq, - if_neg hseg.haS, if_pos hseg.hcS, Bool.not_not, hsame] + 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, - if_neg hseg.hdS, if_pos hseg.hbS, Bool.not_not, + 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, - if_pos hseg.hbS, if_neg hseg.hdS, hbflip, hdflip, hsame] + 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 [if_pos (hseg.match_mem f hfS h2 h3), if_pos hfS, + · rw [ite_eq_left (hseg.match_mem f hfS h2 h3), ite_eq_left hfS, o.match_flip f hf] - · rw [if_neg (hseg.match_notMem hsq hf hfS h1 h4), if_neg hfS] + · 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 @@ -180,9 +180,9 @@ noncomputable def RelTransitionSystem.Orientation.segFlip else o.isOut (W.pairing f)) = !(if f ∈ S then !o.isOut f else o.isOut f) by_cases hfS : f ∈ S - · rw [if_pos (hseg.pairing_mem f hfS), if_pos hfS, + · rw [ite_eq_left (hseg.pairing_mem f hfS), ite_eq_left hfS, o.pairing_flip f hf hp] - · rw [if_neg (hseg.pairing_notMem hfS), if_neg hfS] + · rw [ite_eq_right (hseg.pairing_notMem hfS), ite_eq_right hfS] exact o.pairing_flip f hf hp section SegFlipEval @@ -195,7 +195,7 @@ 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 := if_neg hf + hseg).isOut f = o.isOut f := ite_eq_right hf end SegFlipEval @@ -223,8 +223,8 @@ noncomputable def segFlipColouring (hSpair : ∀ f ∈ S, W.pairing f ∈ S) { ⟨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 [if_pos (hSpair _ hg), if_pos hg, φ.prop g] - · rw [if_neg (hnot _ hg), if_neg hg, φ.prop g] + · 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. -/ @@ -244,13 +244,13 @@ theorem segFlipColouring_involutive intro φ apply Subtype.ext funext g - show (if g.val ∈ S then + 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 [if_pos hg, segFlipColouring_val hSpair φ g, if_pos hg, + · rw [ite_eq_left hg, segFlipColouring_val hSpair φ g, ite_eq_left hg, oddPartner_invol] - · rw [if_neg hg, segFlipColouring_val hSpair φ g, if_neg hg] + · 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. -/ @@ -265,7 +265,7 @@ theorem coreOddBoundaryMatch_segFlipColouring {k ℓ : ℕ} (segFlipColouring hSpair φ).val ⟨W.boundaryFlag i, hcore⟩ = φ.val ⟨W.boundaryFlag i, hcore⟩ := by intro i hcore - rw [segFlipColouring_val hSpair φ _, if_neg (hSb i)] + rw [segFlipColouring_val hSpair φ _, ite_eq_right (hSb i)] unfold coreOddBoundaryMatch constructor · intro H i cc hst hcore @@ -291,14 +291,14 @@ private theorem flipVal_of_mem {φ φ' : F.CoreOddColouring ℓ} 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, if_pos hg] + 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, if_neg hg] + rw [hφ' g, ite_eq_right hg] /-! ### Vertex-local in-sets -/ @@ -316,12 +316,14 @@ noncomputable def flipS (S : Finset W.Flag) (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) @@ -329,14 +331,16 @@ private noncomputable def diffAtS (S : Finset W.Flag) /-- 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 := - Finset.mem_filter + 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 := - Finset.mem_filter + 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. -/ @@ -363,12 +367,14 @@ 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 := - Finset.mem_filter + 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 := - Finset.mem_filter + 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) : @@ -549,20 +555,20 @@ private theorem inb_flip (hd : SegData κ κ' o o' S v P Q R T) · rintro ⟨hgfl, hgat, hgout⟩ rw [hd.hiso g] at hgout by_cases hgS : g ∈ S - · rw [if_pos hgS] at hgout + · 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 [if_neg hgS] at hgout + · 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, if_neg hgS] + rw [hd.hiso g, ite_eq_right hgS] exact hgout · refine ⟨hgfl, hgat, ?_⟩ - rw [hd.hiso g, if_pos hgS, hgout] + rw [hd.hiso g, ite_eq_left hgS, hgout] rfl /-- Away from the move's vertex, the outgoing segment flags are the @@ -993,39 +999,35 @@ private theorem evalList_flip_ne (hd : SegData κ κ' o o' S v P Q R T) simp only [List.nil_append] at hp rw [hp] -/-- At the move's vertex: the flipped vertex list. -/ -private theorem evalList_flip_v (hd : SegData κ κ' o o' S v P Q R T) +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) : - hM.evalOdd μ (F.coreOddListAt o' φ' v) = - (-1 : ℂ) ^ (flipS S o v).card * - hM.evalOdd μ (F.coreOddListAt o φ v) := by + 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 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 Hnew : ∀ g ∈ P :: (((keepS S o v).erase P).toList ++ R :: (((flipS S o v).erase Q).toList.map κ.match_)), g ∈ F.internalFlags := by @@ -1075,9 +1077,6 @@ private theorem evalList_flip_v (hd : SegData κ κ' o o' S v P Q R T) 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] - 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 κ' φ')) @@ -1187,6 +1186,78 @@ private theorem evalList_flip_v (hd : SegData κ κ' o o' S v P Q R T) 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⟩, @@ -1358,6 +1429,7 @@ private theorem vertexProd (hd : SegData κ κ' o o' S v P Q R T) (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 ℓ α) @@ -1376,7 +1448,7 @@ private theorem phiSum (hd : SegData κ κ' o o' S v P Q R T) (segFlipColouring_involutive hd.hSpair (ℓ := ℓ))) _).symm).trans (Finset.sum_congr rfl (fun φ _ => ?_)) - show (if F.coreOddBoundaryMatch st + change (if F.coreOddBoundaryMatch st (segFlipColouring hd.hSpair φ) then ∏ vv : W.Vertex, ((F.coreOddSignAt o' (segFlipColouring hd.hSpair φ) @@ -1394,6 +1466,7 @@ private theorem phiSum (hd : SegData κ κ' o o' S v P Q R T) 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 ℓ α) @@ -1550,7 +1623,7 @@ 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 - haveI : DecidablePred (fun m : ℕ => 1 ≤ m ∧ + have : DecidablePred (fun m : ℕ => 1 ≤ m ∧ (∀ j, j < m → W.pairing (iterWalk κ c j) ∈ F.internalFlags) ∧ iterWalk κ c m = a) := fun m => Classical.dec _ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/OpenCircuits.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/OpenCircuits.lean index be6cd809b9..cd38471b9c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/OpenCircuits.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OpenCircuits.lean @@ -37,7 +37,7 @@ whose forward walk eventually returns to them. namespace RS -open scoped Classical + variable {α : Type} {W : Fragment α} @@ -122,16 +122,17 @@ theorem RelTransitionSystem.periodicFlag_step refine ⟨iterWalk_mem_internal_of_periodic κ hf' 1 (by omega), n, hn1, fun j hj => ?_, ?_⟩ · -- iterWalk κ f 1 is definitionally κ.match_ (W.pairing f) - show W.pairing (iterWalk κ (κ.match_ (W.pairing f)) j) ∈ + change W.pairing (iterWalk κ (κ.match_ (W.pairing f)) j) ∈ F.internalFlags rw [iterWalk_shift] exact all_pairings_internal_of_periodic κ hf' (j + 1) - · show iterWalk κ (κ.match_ (W.pairing f)) n = + · 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 := @@ -162,7 +163,7 @@ theorem RelTransitionSystem.internalWalk_periodic (hf : f ∈ κ.periodicFlags) : κ.internalWalk f ∈ κ.periodicFlags := by rw [κ.mem_periodicFlags] at hf ⊢ - show κ.PeriodicFlag (κ.match_ (W.pairing f)) + change κ.PeriodicFlag (κ.match_ (W.pairing f)) rw [show κ.match_ (W.pairing f) = iterWalk κ f 1 from rfl] exact κ.periodicFlag_step hf @@ -413,7 +414,7 @@ theorem internal_periodic_or_terminates · -- Walk exits at some step. Find the first exit. right simp only [not_forall] at hexall - haveI : DecidablePred (fun k => + have : DecidablePred (fun k => W.pairing (iterWalk κ f k) ∉ F.internalFlags) := fun k => Classical.dec _ have hk₀_spec := Nat.find_spec hexall @@ -487,7 +488,7 @@ theorem walkPerm_revPerm_walkPerm (κ : F.RelTransitionSystem) : have hp0 : W.pairing x.val ∈ F.internalFlags := all_pairings_internal_of_periodic κ (κ.mem_periodicFlags.mp x.prop) 0 - show κ.internalWalk (W.pairing (κ.internalWalk x.val)) = + change κ.internalWalk (W.pairing (κ.internalWalk x.val)) = W.pairing x.val calc κ.internalWalk (W.pairing (κ.internalWalk x.val)) = κ.match_ (W.pairing (W.pairing @@ -500,7 +501,7 @@ theorem walkPerm_revPerm_walkPerm (κ : F.RelTransitionSystem) : theorem revPerm_mul_self (κ : F.RelTransitionSystem) : revPerm κ * revPerm κ = 1 := by ext x - show W.pairing (W.pairing x.val) = x.val + change W.pairing (W.pairing x.val) = x.val exact W.pairing_invol x.val /-- Equivalently, it is its own inverse. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrbitParities.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrbitParities.lean index eca9e07d56..4130e0614c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrbitParities.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrbitParities.lean @@ -50,7 +50,7 @@ assumption is discharged by well-ordering the label type. namespace RS -open scoped Classical + /-! ## The incoherent double swap: merge then split -/ @@ -149,7 +149,7 @@ second splits them again: `Δ permOrbitCount = 0`. -/ theorem nonSeparatedSegmentParity : NonSeparatedSegmentParity := by intro α W F κ a b c d v hsq hreach classical - letI : LinearOrder α := IsWellOrder.linearOrder WellOrderingRel + let : LinearOrder α := IsWellOrder.linearOrder WellOrderingRel -- localization and pathMatch invariance of the move have hloc : SquareLocalized κ a b c d := squareLocalized_of_walkReach hsq hreach @@ -269,7 +269,7 @@ orbit-disjointness hypothesis. -/ theorem nonSeparatedMergeParity : NonSeparatedMergeParity := by intro α W F κ a b c d v hsq hpc hdisj classical - letI : LinearOrder α := IsWellOrder.linearOrder WellOrderingRel + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientExistence.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientExistence.lean index 9ec615c160..7e4b60b9b1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientExistence.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientExistence.lean @@ -17,7 +17,7 @@ data therefore exist exactly when a transition system does. namespace RS -open scoped Classical + /-! ## Orientation existence Every boundary-relative transition system admits an orientation: @@ -81,21 +81,21 @@ theorem relComplete_internal (κ : F.RelTransitionSystem) {f : W.Flag} (hf : f ∈ F.internalFlags) : relComplete κ f = κ.match_ f := by unfold relComplete - rw [dif_pos hf] + 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 [dif_neg (fun hf => internal_not_boundary hf hb), dif_pos hb] + 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 [dif_neg (fun h1 => hf (mem_flags_of_internalFlags F h1)), - dif_neg (fun h1 => hf (mem_flags_of_boundaryFlags F h1))] + 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) : @@ -169,7 +169,7 @@ noncomputable def relWalkPerm (κ : F.RelTransitionSystem) : (x : {f : W.Flag // f ∈ F.flags}) : (relWalkPerm κ x).val = relComplete κ (W.pairing x.val) := by - show (relMatchPerm κ (F.pairingPerm x)).val = _ + change (relMatchPerm κ (F.pairingPerm x)).val = _ rw [relMatchPerm_val, EdgeSubset.pairingPerm_val] /-- Its inverse walks the other way: match, then cross. -/ @@ -210,7 +210,7 @@ theorem relConj_zpow (κ : F.RelTransitionSystem) (n : ℤ) : (relWalkPerm κ) n _ = (relWalkPerm κ)⁻¹ ^ n := by congr 1 - show F.pairingPerm * relWalkPerm κ * F.pairingPerm⁻¹ = + change F.pairingPerm * relWalkPerm κ * F.pairingPerm⁻¹ = (relWalkPerm κ)⁻¹ rw [hσ_inv] exact relConj κ @@ -374,8 +374,8 @@ noncomputable def relBuildOrientation (κ : F.RelTransitionSystem) : isOut (κ.match_ g) = !isOut g := by intro g hg have hgf : g ∈ F.flags := mem_flags_of_internalFlags F hg - simp only [isOut, dif_pos hgf, - dif_pos (mem_flags_of_internalFlags F (κ.match_mem g 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⟩)) @@ -384,8 +384,8 @@ noncomputable def relBuildOrientation (κ : F.RelTransitionSystem) : isOut (W.pairing g) = !isOut g := by intro g hg _hpg have hgf : g ∈ F.flags := mem_flags_of_internalFlags F hg - simp only [isOut, dif_pos hgf, - dif_pos (F.pairing_mem g hgf)] + 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⟩ : diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean index d8cd045f05..7c8cacc63b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean @@ -54,7 +54,7 @@ convention). namespace RS -open scoped Classical + variable {α : Type} {W : Fragment α} @@ -165,9 +165,9 @@ noncomputable def flipColouring (o o' : κ.Orientation) (if g.val ∈ orientDiff o o' then oddPartner ℓ (φ.val g) else φ.val g) := by by_cases hg : g.val ∈ orientDiff o o' - · rw [if_pos (pairing_mem_orientDiff hpair hg), if_pos hg, + · rw [ite_eq_left (pairing_mem_orientDiff hpair hg), ite_eq_left hg, φ.prop g] - · rw [if_neg (pairing_notMem_orientDiff hpair hg), if_neg hg, + · rw [ite_eq_right (pairing_notMem_orientDiff hpair hg), ite_eq_right hg, φ.prop g] exact hbeta⟩ @@ -179,7 +179,7 @@ theorem flipColouring_val_of_mem (o o' : κ.Orientation) (g : {g : W.Flag // g ∈ F.coreFlags}) (hg : g.val ∈ orientDiff o o') : (flipColouring o o' hpair φ).val g = oddPartner ℓ (φ.val g) := - if_pos hg + ite_eq_left hg /-- Off it the colouring is unchanged. -/ theorem flipColouring_val_of_notMem (o o' : κ.Orientation) @@ -189,7 +189,7 @@ theorem flipColouring_val_of_notMem (o o' : κ.Orientation) (g : {g : W.Flag // g ∈ F.coreFlags}) (hg : g.val ∉ orientDiff o o') : (flipColouring o o' hpair φ).val g = φ.val g := - if_neg hg + 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'`. -/ @@ -224,13 +224,13 @@ theorem flipColouring_involutive (o o' : κ.Orientation) intro φ apply Subtype.ext funext g - show (if g.val ∈ orientDiff o o' then + 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 [if_pos hg, flipColouring_val_of_mem o o' hpair φ g hg, + · rw [ite_eq_left hg, flipColouring_val_of_mem o o' hpair φ g hg, oddPartner_invol] - · rw [if_neg hg, flipColouring_val_of_notMem o o' hpair φ g hg] + · 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 ℓ : ℕ} @@ -371,7 +371,7 @@ 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 [dif_pos + rw [dite_eq_left (F.internalFlags_subset_coreFlags (κ.match_mem _ f.prop))] private theorem coreOddSignAt_eq_prod {ℓ : ℕ} (o : κ.Orientation) @@ -436,6 +436,7 @@ private theorem coreOddSignAt_flip {ℓ : ℕ} (o o' : κ.Orientation) /-! ## 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 := @@ -462,6 +463,7 @@ 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] @@ -496,6 +498,7 @@ private theorem diffAt_eq (o o' : κ.Orientation) (v : W.Vertex) : 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] @@ -510,6 +513,7 @@ private theorem orientDiff_eq_biUnion (o o' : κ.Orientation) : 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 @@ -634,7 +638,7 @@ private theorem evalOdd_coreOddListAt_flip {k ℓ : ℕ} (mem_keepIn.mp (Finset.mem_toList.mp hg)).2 have hmD : κ.match_ g ∉ orientDiff o o' := match_notMem_orientDiff h₁ hgD - show [(flipColouring o o' hpair φ).val + change [(flipColouring o o' hpair φ).val ⟨g, F.internalFlags_subset_coreFlags h₁⟩, oddPartner ℓ ((flipColouring o o' hpair φ).val ⟨κ.match_ g, F.internalFlags_subset_coreFlags @@ -658,7 +662,7 @@ private theorem evalOdd_coreOddListAt_flip {k ℓ : ℕ} {g : W.Flag // g ∈ F.coreFlags}) = ⟨f, F.internalFlags_subset_coreFlags h₂⟩ := Subtype.ext (κ.match_invol f h₂) - show [(flipColouring o o' hpair φ).val + change [(flipColouring o o' hpair φ).val ⟨κ.match_ f, F.internalFlags_subset_coreFlags h₁⟩, oddPartner ℓ ((flipColouring o o' hpair φ).val ⟨κ.match_ (κ.match_ f), @@ -763,6 +767,7 @@ private theorem vertexProd_flip {k ℓ : ℕ} (h : MixedFunctional k ℓ) 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 ℓ) @@ -783,7 +788,7 @@ private theorem phiSum_flip {k ℓ : ℕ} (h : MixedFunctional k ℓ) refine ((Equiv.sum_comp (Function.Involutive.toPerm _ (flipColouring_involutive o o' hpair (ℓ := ℓ))) _).symm).trans (Finset.sum_congr rfl (fun φ _ => ?_)) - show (if F.coreOddBoundaryMatch st (flipColouring o o' hpair φ) + 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairCloseComm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairCloseComm.lean index 79ff0590a3..90f99bf215 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairCloseComm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairCloseComm.lean @@ -58,7 +58,7 @@ private noncomputable def pairCloseAmbient _root_.Equiv.sumComm F.Vertex G.Vertex attach_comm f := by rcases f with g | g - · show (((F.attach g).map id + · change (((F.attach g).map id (finCongr (by omega : t = t + 0))).map Sum.inr Sum.inr).map id (pairCloseSwap t) = @@ -68,7 +68,7 @@ private noncomputable def pairCloseAmbient (_root_.Equiv.sumComm F.Vertex G.Vertex) id rcases F.attach g with v | ℓ <;> rfl - · show (((G.attach g).map id + · change (((G.attach g).map id (finCongr (by omega : t = 0 + t))).map Sum.inl Sum.inl).map id (pairCloseSwap t) = @@ -81,7 +81,7 @@ private noncomputable def pairCloseAmbient pairing_comm f := by rcases f with g | g <;> rfl circles_eq := by - show F.circles + G.circles = + change F.circles + G.circles = G.circles + F.circles omega @@ -97,7 +97,7 @@ private theorem mapPairs_pcs_symm (t : ℕ) : (List.map_congr_left fun k _ => ?_) -- Each pair: (Sum.inl ⟨0+k, _⟩, Sum.inr ⟨k, _⟩) -- .symm acts as pcSwapFun since self-inverse - show (pcSwapFun t (Sum.inl ⟨0 + k.val, _⟩), + change (pcSwapFun t (Sum.inl ⟨0 + k.val, _⟩), pcSwapFun t (Sum.inr ⟨k.val, _⟩)) = (Sum.inr ⟨k.val, _⟩, Sum.inl ⟨0 + k.val, _⟩) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean index 839a95fb14..676a7ffdf5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean @@ -41,7 +41,7 @@ Main results: `chainStatusLedger` (the enriched chain induction), namespace RS -open scoped Classical + /-! ## Flip-sign list algebra -/ @@ -102,6 +102,7 @@ theorem flipSignProd_append (f : α → Fin (2 * ℓ)) 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 = @@ -113,13 +114,13 @@ private theorem flipLabels_count_cons (p : α × α) 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 [if_pos h1.symm, if_pos h2.symm, if_pos h1, if_pos h2] - · rw [if_neg (fun h => h2 h.symm), if_pos h1.symm, if_pos h1, - if_neg h2] - · rw [if_pos h2.symm, if_neg (fun h => h1 h.symm), if_neg h1, - if_pos h2] - · rw [if_neg (fun h => h2 h.symm), if_neg (fun h => h1 h.symm), - if_neg h1, if_neg h2] + · 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. -/ @@ -131,7 +132,7 @@ private theorem mem_oddCountLabels_cons {p : α × α} 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 [if_pos h1, if_neg h2] + · rw [ite_eq_left h1, ite_eq_right h2] have hm : i = p.1 ∨ i = p.2 := Or.inl h1 constructor · intro h @@ -139,7 +140,7 @@ private theorem mem_oddCountLabels_cons {p : α × α} · rintro (⟨-, hodd⟩ | ⟨-, hnot⟩) · omega · exact absurd hm hnot - · rw [if_neg h1, if_pos h2] + · rw [ite_eq_right h1, ite_eq_left h2] have hm : i = p.1 ∨ i = p.2 := Or.inr h2 constructor · intro h @@ -147,7 +148,7 @@ private theorem mem_oddCountLabels_cons {p : α × α} · rintro (⟨-, hodd⟩ | ⟨-, hnot⟩) · omega · exact absurd hm hnot - · rw [if_neg h1, if_neg h2] + · rw [ite_eq_right h1, ite_eq_right h2] have hm : ¬(i = p.1 ∨ i = p.2) := by rintro (h | h) · exact h1 h @@ -180,6 +181,7 @@ theorem pairFold_eq_oddCountLabels {L : List (α × α)} 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 (α × α)} @@ -188,7 +190,7 @@ theorem flipColoursFold_apply {L : List (α × α)} if i ∈ oddCountLabels L then oddPartner ℓ (f i) else f i := by induction L generalizing f with | nil => - rw [flipColoursFold_nil, if_neg (fun h => by + rw [flipColoursFold_nil, ite_eq_right (fun h => by rw [mem_oddCountLabels] at h simp [flipLabels_nil] at h)] | cons p L ih => @@ -199,30 +201,30 @@ theorem flipColoursFold_apply {L : List (α × α)} by_cases hm : i = p.1 ∨ i = p.2 · have hfc : flipColours f p i = oddPartner ℓ (f i) := by unfold flipColours - rw [if_pos hm] + 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 [if_pos ho, hfc, oddPartner_invol, if_neg hnot] + 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 [if_neg ho, hfc, if_pos hyes] + rw [ite_eq_right ho, hfc, ite_eq_left hyes] · have hfc : flipColours f p i = f i := by unfold flipColours - rw [if_neg hm] + 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 [if_pos ho, hfc, if_pos hyes] + 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 [if_neg ho, hfc, if_neg hnot] + rw [ite_eq_right ho, hfc, ite_eq_right hnot] end SignAlgebra @@ -232,6 +234,7 @@ 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 β} @@ -262,15 +265,15 @@ private theorem two_indicator_if [LinearOrder α] 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 := - if_neg (fun hc => lt_asymm h hc.1) + ite_eq_right (fun hc => lt_asymm h hc.1) have hcond : (if x < y then P else Q) ↔ P := by - rw [if_pos h] + 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 := - if_neg (fun hc => lt_asymm h hc.1) + ite_eq_right (fun hc => lt_asymm h hc.1) have hcond : (if x < y then P else Q) ↔ Q := by - rw [if_neg (lt_asymm h)] + rw [ite_eq_right (lt_asymm h)] rw [e1, zero_add, if_congr (and_iff_right h) rfl rfl, if_congr hcond rfl rfl] @@ -281,8 +284,8 @@ private theorem indicator_pair_one [LinearOrder α] ((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 [if_pos h, if_neg (lt_asymm h)] - · rw [if_neg (lt_asymm h), if_pos 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. -/ @@ -297,7 +300,7 @@ private theorem chordPairCrossSym_swap_pair [LinearOrder α] (a₁ a₂ b₁ b₂ : α) : chordPairCrossSym (a₂, a₁) (b₂, b₁) ↔ chordPairCrossSym (a₁, a₂) (b₁, b₂) := by - show (ChordPairCross (min a₂ a₁) (max a₂ a₁) (min b₂ b₁) + 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₁)) ↔ @@ -386,7 +389,7 @@ private theorem flipColours_matches {st : GenBoundaryState k ℓ α} rw [hst] at hic have hfc : flipColours g (l₁, l₂) i = oddPartner ℓ (g i) := by unfold flipColours - rw [if_pos hm] + rw [ite_eq_left hm] rcases hval : st i with a | c₀ · rw [hval] at hic simp only [Sum.map_inl] at hic @@ -400,7 +403,7 @@ private theorem flipColours_matches {st : GenBoundaryState k ℓ α} (fun h => hm (Or.inr h)) have hfc : flipColours g (l₁, l₂) i = g i := by unfold flipColours - rw [if_neg hm] + rw [ite_eq_right hm] rw [hst] at hic rw [hfc] exact hg i c hic @@ -417,7 +420,7 @@ private theorem flipColoursFold_matches rw [flipColoursFold_apply hd g i, ← pairFold_eq_oddCountLabels hd] by_cases hm : i ∈ pairFold T · rw [stateOddFlipSet_of_mem hm] at hic - rw [if_pos hm] + rw [ite_eq_left hm] rcases hval : st i with a | c₀ · rw [hval] at hic simp only [Sum.map_inl] at hic @@ -427,7 +430,7 @@ private theorem flipColoursFold_matches rw [hg i c₀ hval] exact Sum.inr.inj hic · rw [stateOddFlipSet_of_notMem hm] at hic - rw [if_neg hm] + rw [ite_eq_right hm] exact hg i c hic end StateColours @@ -951,6 +954,54 @@ private theorem nonsep_anti_card_mixed 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 @@ -996,19 +1047,9 @@ private theorem nonsep_anti_card_untoggled else F.boundaryLabel hε₂ < F.boundaryLabel (κ.pathMatch_mem hε₂)) then 1 else 0) + 1 := 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 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ε₂)) @@ -1183,27 +1224,8 @@ private theorem nonsep_anti_card_untoggled -- 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 : 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δ) + 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 @@ -1229,6 +1251,7 @@ private theorem nonsep_anti_card_untoggled 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 @@ -1456,6 +1479,441 @@ end NonsepCount 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 κ₁ κ₂`, @@ -1522,371 +1980,9 @@ theorem stepStatusLedger -- orientation splits into the separated and non-separated cases. obtain ⟨ε₁, ε₂, hε₁, hε₂, hne, hPne, hcross, hfar, hout⟩ := pathMatch_repair_swap hsq hloc - 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 by_cases hsame : o₁.isOut c = o₁.isOut a - · -- ─────── non-separated ─────── - -- 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' - · -- ─────── separated ─────── - -- 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' + · 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingConnectivity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingConnectivity.lean index 777c6e2625..2a8e9f2c42 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingConnectivity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingConnectivity.lean @@ -19,7 +19,7 @@ of the signed summand from connectivity and the per-step ledger. namespace RS -open scoped Classical + variable {α : Type} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSignature.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSignature.lean index a94724eeed..d948603af5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSignature.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSignature.lean @@ -18,7 +18,7 @@ holonomy bookkeeping. namespace RS -open scoped Classical + variable {α : Type} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSwap.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSwap.lean index b0b5e155b0..468caeaf70 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSwap.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSwap.lean @@ -21,7 +21,7 @@ transposition conjugations. namespace RS -open scoped Classical + variable {α : Type} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingValue.lean index 2c354fbe01..a27c3c6575 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingValue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingValue.lean @@ -19,7 +19,7 @@ function of the pairing, riding on the proved block connectivity. namespace RS -open scoped Classical + variable {α : Type} @@ -54,7 +54,7 @@ theorem signedValueAt_eq [LinearOrder α] {W : Fragment α} {F : EdgeSubset W} F.throughSummand hM st hbnd o κ.openCircuitCount := by have hne : Nonempty {o : κ.Orientation // PathCanonical o} := ⟨⟨o, hc⟩⟩ - rw [signedValueAt, dif_pos hne] + rw [signedValueAt, dite_eq_left hne] exact congrArg (fun x => pathSign κ * x) (throughSummand_pathCanonical hM st hbnd (Classical.choice hne).prop hc _) @@ -102,7 +102,7 @@ theorem signedValueAt_samePairing obtain ⟨o, hc⟩ := canonical_transfer_of_samePairing HLedger hM st hbnd (SamePairing.symm hsp) o' hc' exact h ⟨⟨o, hc⟩⟩ - rw [signedValueAt, dif_neg h, signedValueAt, dif_neg h'] + rw [signedValueAt, dite_eq_right h, signedValueAt, dite_eq_right h'] end EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialClose.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialClose.lean index e7a6b0652d..eb05f8cebe 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialClose.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialClose.lean @@ -162,31 +162,31 @@ def pcSurvValEquiv (s t u v : ℕ) : ⟨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 show (s + u) ≤ (s + u) + (k.val - s); omega, - by show (s + u) + (k.val - s) < (s + u) + t + 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 [dif_pos hb] + · 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 [dif_neg hb, - dif_neg (show ¬ s + (b.val - (s + u)) < s by omega)] + 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 - show (s + u) + (s + (b.val - (s + u)) - s) = b.val + change (s + u) + (s + (b.val - (s + u)) - s) = b.val omega))) right_inv k := by by_cases hk : k.val < s - · simp only [dif_pos hk] - · simp only [dif_neg hk, - dif_neg (show ¬ (s + u) + (k.val - s) < s by omega)] + · 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 - show s + ((s + u) + (k.val - s) - (s + u)) = k.val + change s + ((s + u) + (k.val - s) - (s + u)) = k.val omega) /-- The survivor identification of the `z`-gluing. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseCompose.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseCompose.lean index 9d6d7d96fc..a0ccd77f7d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseCompose.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseCompose.lean @@ -104,12 +104,12 @@ theorem interfacePairs_zsplit (s t u v : ℕ) : (List.map_congr_left fun l _ => ?_) · refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) (congrArg Sum.inr (Fin.ext ?_)) - · show 0 + j.val = j.val + · change 0 + j.val = j.val omega · rfl · refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) (congrArg Sum.inr (Fin.ext ?_)) - · show 0 + (u + l.val) = u + l.val + · change 0 + (u + l.val) = u + l.val omega · rfl @@ -133,7 +133,7 @@ private theorem pc_compose_ground_v_aux (s t u v : ℕ) : 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) - show Sum.inr ((pcReshuffle s t u v).symm + 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⟩ : @@ -161,7 +161,7 @@ private theorem pc_compose_ground_u_aux (s t u v : ℕ) : 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) - show Sum.inr ((pcReshuffle s t u v).symm + 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⟩ : @@ -235,29 +235,29 @@ theorem pc_compose_meet (s t u v : ℕ) : 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 show ¬ (pcReshuffle s t u v b).val < u + v + (by change ¬ (pcReshuffle s t u v b).val < u + v rw [hbv] - show ¬ (u + v) + b.val < u + v + change ¬ (u + v) + b.val < u + v omega)) - show finCongr (by omega : 0 + (s + t) = s + t) + 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]; show u + v ≤ (u + v) + b.val; omega), + (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 ?_ - show 0 + ((pcReshuffle s t u v b).val - (u + v)) = b.val + change 0 + ((pcReshuffle s t u v b).val - (u + v)) = b.val rw [hbv] - show 0 + ((u + v) + b.val - (u + v)) = b.val + 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 - show b.val = (s + u) + (b.val - (s + u)) + change b.val = (s + u) + (b.val - (s + u)) omega) have hbv : pcReshuffle s t u v b = Fin.natAdd (u + v) @@ -271,27 +271,27 @@ theorem pc_compose_meet (s t u v : ℕ) : 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 show ¬ (pcReshuffle s t u v b).val < u + v + (by change ¬ (pcReshuffle s t u v b).val < u + v rw [hbv] - show ¬ (u + v) + (s + (b.val - (s + u))) < u + v + change ¬ (u + v) + (s + (b.val - (s + u))) < u + v omega)) - show finCongr (by omega : 0 + (s + t) = s + t) + 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] - show u + v ≤ (u + v) + (s + (b.val - (s + u))) + 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 ?_ - show 0 + ((pcReshuffle s t u v b).val - (u + v)) = + change 0 + ((pcReshuffle s t u v b).val - (u + v)) = s + (b.val - (s + u)) rw [hbv] - show 0 + ((u + v) + (s + (b.val - (s + u))) - (u + v)) = + change 0 + ((u + v) + (s + (b.val - (s + u))) - (u + v)) = s + (b.val - (s + u)) omega diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean index 4788d32a0a..5ce40187e9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean @@ -55,18 +55,18 @@ noncomputable def disjUnionShuffle {α β γ : Type} vertexEquiv := sumShuffleEquiv W₂.Vertex W₁.Vertex W₃.Vertex attach_comm := fun f => by rcases f with f | (f | f) - · show ((((W₁.attach f).map Sum.inl Sum.inl).map + · 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 - · show (((W₂.attach f).map Sum.inl Sum.inl).map id + · 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 - · show ((((W₃.attach f).map Sum.inr Sum.inr).map + · 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 @@ -75,7 +75,7 @@ noncomputable def disjUnionShuffle {α β γ : Type} pairing_comm := fun f => by rcases f with f | (f | f) <;> rfl circles_eq := by - show W₁.circles + (W₂.circles + W₃.circles) = + change W₁.circles + (W₂.circles + W₃.circles) = W₂.circles + (W₁.circles + W₃.circles) omega @@ -115,7 +115,7 @@ private theorem pc_tensor_ground_v_aux (s t u v : ℕ) : 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) - show Sum.inr ((interleaveEquiv s t u v).symm + 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), @@ -143,7 +143,7 @@ private theorem pc_tensor_ground_u_aux (s t u v : ℕ) : 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) - show Sum.inr ((interleaveEquiv s t u v).symm + 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⟩ : @@ -316,6 +316,10 @@ noncomputable def pcTensorQs (s t u v : ℕ) := Fragment.mapPairs (pcTensorPeel s t u v).symm (zClosePairs s t u v) +private theorem pcTensorQs_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 : ℕ) : @@ -351,7 +355,7 @@ noncomputable def pcTensorNormal {s t u v : ℕ} let eP := pcTensorPeel s t u v let qsP := pcTensorQs s t u v have wfqsP : Fragment.PairsWF qsP := - Fragment.mapPairs_wf eP.symm _ (zClosePairs_wf s t u v) + pcTensorQs_wf s t u v let shufE := sumShuffleEquiv (Fin (u + v)) (Fin (s + t)) (Fin (u + v)) let ps₂ := Fragment.inrPairs (α := Fin (s + t)) @@ -449,8 +453,8 @@ theorem pcSurvEquiv_val_low (s t u v : ℕ) (hb : b.val < s) : pcSurvEquiv s t u v ⟨Sum.inr b, hsurv⟩ = ⟨b.val, by omega⟩ := by - show (if h : b.val < s then _ else _ : Fin (s + t)) = _ - rw [dif_pos hb] + 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 : ℕ) @@ -462,8 +466,8 @@ theorem pcSurvEquiv_val_high (s t u v : ℕ) (h2 : b.val < (s + u) + t) : pcSurvEquiv s t u v ⟨Sum.inr b, hsurv⟩ = ⟨s + (b.val - (s + u)), by omega⟩ := by - show (if h : b.val < s then _ else _ : Fin (s + t)) = _ - rw [dif_neg hb] + 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. -/ @@ -486,14 +490,14 @@ theorem pcTensorLabel_eq (s t u v : ℕ) : (forall_ne_iff_not_mem_flat _ _).mpr ((pcSurv_iff s t u v _).mpr (Or.inl (by rw [hval]; exact hx))) - show pcSurvEquiv s t u v + 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 show x'.val = s + (x'.val - s); omega) + 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] @@ -509,14 +513,14 @@ theorem pcTensorLabel_eq (s t u v : ℕ) : ((pcSurv_iff s t u v _).mpr (Or.inr ⟨by rw [hval]; omega, by rw [hval]; have := x'.isLt; omega⟩)) - show pcSurvEquiv s t u v + 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 ?_ - show s + ((interleaveEquiv s t u v (Sum.inl x')).val - + change s + ((interleaveEquiv s t u v (Sum.inl x')).val - (s + u)) = x'.val rw [hval] omega diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathCanon.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathCanon.lean index 3b3830e1c8..bbf8cb3d73 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathCanon.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathCanon.lean @@ -23,7 +23,7 @@ data, and the corrected independence interface quantifies over it. namespace RS -open scoped Classical + variable {α : Type} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean index 30f75f86f9..20a3e2dcb9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean @@ -52,7 +52,7 @@ factor and the case analysis that controls it. namespace RS -open scoped Classical + /-! ## (i) Chord combinatorics: the third-chord parity lemma -/ @@ -106,21 +106,21 @@ theorem chordPairCross_parity [LinearOrder γ] rintro (⟨-, h⟩ | ⟨-, h⟩) · exact h hw · exact h hu - rw [if_neg hnX, if_pos hu, if_pos hw] + 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 [if_pos hX, if_pos hu, if_neg 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 [if_pos hX, if_neg hu, if_pos hw] + 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 [if_neg hnX, if_neg hu, if_neg hw] + rw [ite_eq_right hnX, ite_eq_right hu, ite_eq_right hw] private theorem inside_sum_eq [LinearOrder γ] (x y u₁ w₁ u₂ w₂ : γ) : @@ -952,10 +952,10 @@ noncomputable def RelTransitionSystem.Orientation.flipOrbit else o.isOut (κ.match_ f)) = !(if OrbitFlag κ g f then !o.isOut f else o.isOut f) by_cases hfo : OrbitFlag κ g f - · rw [if_pos (orbitFlag_match hg hfo), if_pos hfo, + · rw [ite_eq_left (orbitFlag_match hg hfo), ite_eq_left hfo, o.match_flip f hf] - · rw [if_neg (fun hcon => hfo (orbitFlag_of_match hg hf hcon)), - if_neg hfo] + · 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 @@ -963,27 +963,27 @@ noncomputable def RelTransitionSystem.Orientation.flipOrbit 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 [if_pos (orbitFlag_pairing hfo), if_pos hfo, + · rw [ite_eq_left (orbitFlag_pairing hfo), ite_eq_left hfo, o.pairing_flip f hf hp] - · rw [if_neg (fun hcon => hfo (orbitFlag_of_pairing hcon)), - if_neg hfo] + · 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 - show (if OrbitFlag κ g f then !o.isOut f else o.isOut f) = + change (if OrbitFlag κ g f then !o.isOut f else o.isOut f) = !o.isOut f - exact if_pos hf + 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 - show (if OrbitFlag κ g f then !o.isOut f else o.isOut f) = + change (if OrbitFlag κ g f then !o.isOut f else o.isOut f) = o.isOut f - exact if_neg hf + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathMatch.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathMatch.lean index 33bd8aea07..4c6c5d0686 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathMatch.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathMatch.lean @@ -33,7 +33,7 @@ on `j` using `match_invol`. namespace RS -open scoped Classical + variable {α : Type} {W : Fragment α} @@ -57,13 +57,13 @@ theorem traceChain_internal (κ : F.RelTransitionSystem) traceChain κ (n + 1) f = traceChain κ n (κ.match_ (W.pairing f)) := by conv_lhs => unfold traceChain - simp only [if_neg (not_boundary_of_internal h), dif_pos h] + 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 [if_pos h] + conv_lhs => unfold traceChain; simp only [ite_eq_left h] /-- The chain fails on a partner outside the subset. -/ theorem traceChain_neither (κ : F.RelTransitionSystem) @@ -72,7 +72,7 @@ theorem traceChain_neither (κ : F.RelTransitionSystem) (hi : W.pairing f ∉ F.internalFlags) : traceChain κ (n + 1) f = none := by conv_lhs => unfold traceChain - simp only [if_neg hb, dif_neg hi] + simp only [ite_eq_right hb, dite_eq_right hi] /-! ### Fuel monotonicity -/ @@ -132,6 +132,16 @@ theorem iterWalk_succ (κ : F.RelTransitionSystem) 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 : ℕ) : @@ -307,7 +317,7 @@ theorem chain_terminates_with_data omega have hex' : ∃ k, W.pairing (iterWalk κ b k) ∉ F.internalFlags := ⟨_, hex.choose_spec.2⟩ - haveI : DecidablePred (fun k => + have : DecidablePred (fun k => W.pairing (iterWalk κ b k) ∉ F.internalFlags) := fun k => Classical.dec _ set k₀ := Nat.find hex' diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PermCompose.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PermCompose.lean index ca27d55edd..ae45529e46 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PermCompose.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PermCompose.lean @@ -36,13 +36,13 @@ noncomputable def permFragmentRelabelOutPerm {t : ℕ} attach_comm := fun f => by obtain ⟨k, b⟩ := f cases b - · show Sum.inr (outPermEquiv t σ + · 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] - · show Sum.inr (outPermEquiv t σ + · 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)) @@ -67,7 +67,7 @@ noncomputable def strandBundleRelabelBoth {t : ℕ} attach_comm := fun f => by obtain ⟨k, b⟩ := f cases b - · show Sum.inr (⟨(δ k).val, + · 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⟩) @@ -76,7 +76,7 @@ noncomputable def strandBundleRelabelBoth {t : ℕ} Fin.castAdd t k from Fin.ext rfl, _root_.Equiv.trans_apply, inPermEquiv_low, outPermEquiv_low] exact Fin.ext rfl - · show Sum.inr (⟨t + (δ k).val, + · 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⟩) @@ -104,7 +104,7 @@ theorem outPerm_shift_both {t : ℕ} (σ τ : Equiv.Perm (Fin t)) : inPermEquiv_low] · rw [show ℓ = (Fin.natAdd t ⟨ℓ.val - t, by have := ℓ.isLt; omega⟩ : Fin (t + t)) from - Fin.ext (by show ℓ.val = t + (ℓ.val - t); omega)] + Fin.ext (by change ℓ.val = t + (ℓ.val - t); omega)] simp only [_root_.Equiv.trans_apply, outPermEquiv_high, inPermEquiv_high] refine congrArg (Fin.natAdd t) ?_ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PermFragment.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PermFragment.lean index 017ebe46ea..7c9ce9c3b3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PermFragment.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PermFragment.lean @@ -38,32 +38,32 @@ def permFragment {t : ℕ} (σ : Equiv.Perm (Fin t)) : else (σ.symm ⟨ℓ.val - t, by have := ℓ.isLt; omega⟩, true) attach_boundaryFlag := fun ℓ => by by_cases h : ℓ.val < t - · rw [dif_pos h] + · rw [dite_eq_left h] exact congrArg Sum.inr (Fin.ext rfl) - · rw [dif_neg h] + · rw [dite_eq_right h] refine congrArg Sum.inr (Fin.ext ?_) - show t + (σ (σ.symm ⟨ℓ.val - t, by have := ℓ.isLt; omega⟩)).val = + change t + (σ (σ.symm ⟨ℓ.val - t, by have := ℓ.isLt; omega⟩)).val = ℓ.val rw [Equiv.apply_symm_apply] - show t + (ℓ.val - t) = ℓ.val + 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, if_false] at hℓ + · simp only [Bool.false_eq_true, ite_false] at hℓ subst hℓ - rw [dif_pos a.isLt] - · simp only [if_true] at hℓ + rw [dite_eq_left a.isLt] + · simp only [ite_true] at hℓ subst hℓ - rw [dif_neg (show ¬ t + (σ a).val < t by omega)] + rw [dite_eq_right (show ¬ t + (σ a).val < t by omega)] refine Prod.ext_iff.mpr ⟨?_, rfl⟩ - show a = σ.symm ⟨t + (σ a).val - t, + 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 show t + (σ a).val - t = (σ a).val; omega)] + Fin.ext (by change t + (σ a).val - t = (σ a).val; omega)] exact (σ.symm_apply_apply a).symm circles := 0 @@ -87,39 +87,39 @@ def permHighEquiv {t : ℕ} (σ : Equiv.Perm (Fin t)) : left_inv ℓ := by dsimp only by_cases h : ℓ.val < t - · simp only [dif_pos h] - · rw [dif_neg h, dif_neg (by - show ¬ t + (σ ⟨ℓ.val - t, _⟩).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 ?_ - show t + (σ.symm ⟨t + (σ ⟨ℓ.val - t, _⟩).val - t, _⟩).val = ℓ.val + 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 - show t + _ - t = _ + change t + _ - t = _ omega)] rw [Equiv.symm_apply_apply] - show t + (ℓ.val - t) = ℓ.val + change t + (ℓ.val - t) = ℓ.val omega right_inv ℓ := by dsimp only by_cases h : ℓ.val < t - · simp only [dif_pos h] - · rw [dif_neg h, dif_neg (by - show ¬ t + (σ.symm ⟨ℓ.val - t, _⟩).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 ?_ - show t + (σ ⟨t + (σ.symm ⟨ℓ.val - t, _⟩).val - t, _⟩).val = ℓ.val + 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 - show t + _ - t = _ + change t + _ - t = _ omega)] rw [Equiv.apply_symm_apply] - show t + (ℓ.val - t) = ℓ.val + change t + (ℓ.val - t) = ℓ.val omega /-- A permutation fragment is the strand bundle with its outgoing @@ -133,25 +133,25 @@ noncomputable def permFragmentRelabelBundle {t : ℕ} attach_comm := fun f => by obtain ⟨k, b⟩ := f cases b - · show Sum.inr (permHighEquiv σ ⟨k.val, by have := k.isLt; omega⟩) = + · 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 - show (if h : (⟨k.val, by have := k.isLt; omega⟩ : + change (if h : (⟨k.val, by have := k.isLt; omega⟩ : Fin (t + t)).val < t then _ else _) = _ - rw [dif_pos (show k.val < t from k.isLt)] - · show Sum.inr (permHighEquiv σ ⟨t + k.val, + 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 - show (if h : (⟨t + k.val, by have := k.isLt; omega⟩ : + change (if h : (⟨t + k.val, by have := k.isLt; omega⟩ : Fin (t + t)).val < t then _ else _) = _ - rw [dif_neg (show ¬ t + k.val < t by omega)] + rw [dite_eq_right (show ¬ t + k.val < t by omega)] refine Fin.ext ?_ - show t + (σ ⟨t + k.val - t, _⟩).val = t + (σ k).val + 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 show t + k.val - t = k.val; omega)] + from Fin.ext (by change t + k.val - t = k.val; omega)] pairing_comm := fun _ => rfl circles_eq := rfl diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PropThreeOpen.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PropThreeOpen.lean index 16aa8bf4d6..68c02275a9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PropThreeOpen.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PropThreeOpen.lean @@ -22,7 +22,7 @@ nothing else. namespace RS -open scoped Classical + /-- The paired step in value form, unconditionally. -/ theorem pairedValueLedger : PairedValueLedger := diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean index 984b1d96af..2f0dc18369 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean @@ -36,7 +36,7 @@ namespace RS namespace EdgeSubset -open Classical + variable {α : Type} @@ -107,21 +107,21 @@ theorem dualWeightD_eq_prod_legWeight [Fintype α] {W : Fragment α} unfold dualWeightD legDir refine Finset.prod_congr rfl (fun i _ => ?_) by_cases hb : W.boundaryFlag i ∈ F.boundaryFlags - · rw [dif_pos hb, dif_pos hb] + · rw [dite_eq_left hb, dite_eq_left hb] by_cases ht : tl ⟨i, hb⟩ = true - · rw [if_pos ht] + · rw [ite_eq_left ht] rcases hxi : x i with a | c - · show (1 : ℂ) = legWeight (tl ⟨i, hb⟩) (Sum.inl a) + · change (1 : ℂ) = legWeight (tl ⟨i, hb⟩) (Sum.inl a) rfl - · show dualSign ℓ c = legWeight (tl ⟨i, hb⟩) (Sum.inr c) - show dualSign ℓ c = if tl ⟨i, hb⟩ then dualSign ℓ c else 1 - rw [if_pos ht] - · rw [if_neg ht] + · 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 - · show (1 : ℂ) = if tl ⟨i, hb⟩ then dualSign ℓ c else 1 - rw [if_neg ht] - · rw [dif_neg hb, dif_neg hb] + · 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)) @@ -215,13 +215,13 @@ theorem tPrimeD_eq_zero_of_not_throughAgree [Fintype α] {W : Fragment α} (hag : ¬ ThroughAgree F (untwistD F tl x) hbnd) : F.tPrimeD h κ o tl x = 0 := by unfold tPrimeD - rw [dif_pos hbnd] + 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 [if_pos hev] - exact Finset.sum_eq_zero (fun φ _ => if_neg (fun hφ => + · rw [ite_eq_left hev] + exact Finset.sum_eq_zero (fun φ _ => ite_eq_right (fun hφ => hag (throughAgree_of_edgeOddBoundaryMatch hbnd hφ))) - · rw [if_neg hev] + · rw [ite_eq_right hev] open Classical in /-- **A disagreeing state carries no colouring**, at the chain @@ -236,13 +236,13 @@ theorem tPrime_eq_zero_of_not_throughAgree (hag : ¬ ThroughAgree F (untwist F κ o x) hbnd) : F.tPrime h κ o x = 0 := by unfold tPrime - rw [dif_pos hbnd] + 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 [if_pos hev] - exact Finset.sum_eq_zero (fun φ _ => if_neg (fun hφ => + · rw [ite_eq_left hev] + exact Finset.sum_eq_zero (fun φ _ => ite_eq_right (fun hφ => hag (throughAgree_of_edgeOddBoundaryMatch hbnd hφ))) - · rw [if_neg hev] + · rw [ite_eq_right hev] open Classical in /-- **RS21's `t_h` vanishes at a disagreeing state.** -/ @@ -292,7 +292,7 @@ theorem genBoundarySubsetMatches_of_tPrimeD_ne_zero [Fintype α] {W : Fragment by_contra hc refine hne ?_ unfold tPrimeD - refine dif_neg (fun hb => hc ?_) + refine dite_eq_right (fun hb => hc ?_) exact (genBoundarySubsetMatches_untwistD F tl x).mp hb open Classical in @@ -332,7 +332,7 @@ 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⟩ := dif_pos h + 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 @@ -344,17 +344,17 @@ theorem untwistD_eq_untwistState {t : ℕ} {W : Fragment (Fin t)} funext i by_cases hb : W.boundaryFlag i ∈ F.boundaryFlags · rw [untwistD_apply_mem F tl x hb] - show (if tl ⟨i, hb⟩ then Sum.map id (oddPartner ℓ) (x i) + 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 [if_pos ht, if_pos ht] + · rw [ite_eq_left ht, ite_eq_left ht] rcases x i with a | c <;> rfl - · rw [if_neg ht, if_neg ht] + · rw [ite_eq_right ht, ite_eq_right ht] · rw [untwistD_apply_not_mem F tl x hb] - show x i = if legDir F tl i then dualLeg (x i) else x i - rw [show legDir F tl i = false from dif_neg hb, if_neg (by simp)] + 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 @@ -436,19 +436,19 @@ theorem tPrime_eq_vertexSum [LinearOrder α] [Fintype α] {W : Fragment α} = ((-1 : ℂ) ^ κ.openCircuitCount) * dualWeight F κ o x * F.vertexSum h (untwist F κ o x) hbnd o := by unfold tPrime vertexSum - rw [dif_pos hbnd] + 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 [if_pos hψ, if_pos hψ] + · 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 [if_neg hψ, if_neg hψ] + · rw [ite_eq_right hψ, ite_eq_right hψ] open Classical in /-- **The tensor at given arc directions is the vertex sum, @@ -464,19 +464,19 @@ theorem tPrimeD_eq_vertexSum [Fintype α] {W : Fragment α} = ((-1 : ℂ) ^ κ.openCircuitCount) * dualWeightD F tl x * F.vertexSum h (untwistD F tl x) hbnd o := by unfold tPrimeD vertexSum - rw [dif_pos hbnd] + 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 [if_pos hψ, if_pos hψ] + · 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 [if_neg hψ, if_neg hψ] + · rw [ite_eq_right hψ, ite_eq_right hψ] open Classical in /-- **The tensor in the Gram computation's terms**: a fourth root @@ -549,7 +549,7 @@ theorem pairAgreeValue_pos {t : ℕ} {W₁ W₂ : Fragment (Fin t)} pairAgreeValue F₁ F₂ h o₁ o₂ st = F₁.vertexSum h st h₁ o₁ * F₂.vertexSum h st h₂ o₂ := by unfold pairAgreeValue - rw [dif_pos h₁, dif_pos h₂, if_pos ⟨hag₁, hag₂⟩] + 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 @@ -562,7 +562,7 @@ theorem pairAgreeValue_eq_zero {t : ℕ} {W₁ W₂ : Fragment (Fin t)} (h₁ : ¬ genBoundarySubsetMatches W₁ F₁.flags st) : pairAgreeValue F₁ F₂ h o₁ o₂ st = 0 := by unfold pairAgreeValue - rw [dif_neg h₁] + rw [dite_eq_right h₁] open Classical in /-- **The agreeing value vanishes where the first side @@ -577,10 +577,10 @@ theorem pairAgreeValue_eq_zero_of_not_agree₁ {t : ℕ} (hag : ¬ ThroughAgree F₁ st h₁) : pairAgreeValue F₁ F₂ h o₁ o₂ st = 0 := by unfold pairAgreeValue - rw [dif_pos h₁] + rw [dite_eq_left h₁] by_cases h₂ : genBoundarySubsetMatches W₂ F₂.flags st - · rw [dif_pos h₂, if_neg (fun hx => hag hx.1)] - · rw [dif_neg h₂] + · 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 @@ -596,8 +596,8 @@ theorem pairAgreeValue_eq_zero_of_not_agree₂ {t : ℕ} pairAgreeValue F₁ F₂ h o₁ o₂ st = 0 := by unfold pairAgreeValue by_cases h₁ : genBoundarySubsetMatches W₁ F₁.flags st - · rw [dif_pos h₁, dif_pos h₂, if_neg (fun hx => hag hx.2)] - · rw [dif_neg h₁] + · 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 @@ -716,7 +716,7 @@ theorem sum_sum_superForm_tFullD {t : ℕ} {W₁ W₂ : Fragment (Fin t)} (hused i).mpr (boundaryFlag_mem_boundaryFlags hf) obtain ⟨c, hc⟩ := (hx i).mp (mem_flags_of_boundaryFlags F₁ h1) exact ⟨oddPartner ℓ c, by - show dualLeg (x i) = Sum.inr (oddPartner ℓ c) + change dualLeg (x i) = Sum.inr (oddPartner ℓ c) rw [hc]; rfl⟩ · rintro ⟨c, hc⟩ have hodd : ∃ d, x i = Sum.inr d := @@ -816,7 +816,7 @@ theorem sum_sum_superForm_tFullD {t : ℕ} {W₁ W₂ : Fragment (Fin t)} have hzp : pairAgreeValue F₁ F₂ h o₁ o₂ (untwistState (legDir F₁ M₁.tail) x) = 0 := by unfold pairAgreeValue - refine dif_neg (fun hc => hx ?_) + 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] @@ -833,7 +833,7 @@ theorem sum_sum_superForm_tFullD {t : ℕ} {W₁ W₂ : Fragment (Fin t)} by_contra hc refine hne ?_ unfold pairAgreeValue - refine dif_neg (fun hd => hc ?_) + 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₁ @@ -844,7 +844,7 @@ theorem sum_sum_superForm_tFullD {t : ℕ} {W₁ W₂ : Fragment (Fin t)} by_contra hc refine hne ?_ unfold pairAgreeValue - refine dif_neg (fun hd => hc ?_) + 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₁] @@ -853,7 +853,7 @@ theorem sum_sum_superForm_tFullD {t : ℕ} {W₁ W₂ : Fragment (Fin t)} by_contra hc refine hne ?_ unfold pairAgreeValue - refine dif_neg (fun hd => hc ?_) + 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)) @@ -918,7 +918,7 @@ theorem vertexSum_stateOddFlip_through {W : Fragment α} · 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 [if_pos (heven.mpr hψ), if_pos hψ] + · 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 @@ -932,9 +932,9 @@ theorem vertexSum_stateOddFlip_through {W : Fragment α} rw [← stateOddFlip_of_ne (st := st) hn₁ hn₂] exact hst by_cases hφ : F.coreOddBoundaryMatch st φ - · rw [if_pos (hcore.mpr hφ), if_pos hφ] - · rw [if_neg (fun hx => hφ (hcore.mp hx)), if_neg hφ] - · rw [if_neg (fun hx => hψ (heven.mp hx)), if_neg hψ] + · 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 @@ -995,20 +995,20 @@ theorem tPrime_portFlip [LinearOrder α] [Fintype α] {W : Fragment α} 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 [if_pos ht, if_pos ht] - show Sum.inr (oddPartner ℓ (oddPartner ℓ c₁)) = Sum.inr c₁ + · rw [ite_eq_left ht, ite_eq_left ht] + change Sum.inr (oddPartner ℓ (oddPartner ℓ c₁)) = Sum.inr c₁ rw [oddPartner_invol] - · rw [if_neg ht, if_neg ht] + · 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 [if_pos ht, if_pos ht] - show Sum.inr (oddPartner ℓ (oddPartner ℓ c₂)) = Sum.inr c₂ + · rw [ite_eq_left ht, ite_eq_left ht] + change Sum.inr (oddPartner ℓ (oddPartner ℓ c₂)) = Sum.inr c₂ rw [oddPartner_invol] - · rw [if_neg ht, if_neg ht] + · 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' @@ -1053,13 +1053,13 @@ theorem tPrime_portFlip [LinearOrder α] [Fintype α] {W : Fragment α} then c₂ else oddPartner ℓ c₂) : ℤ) : ℂ) = -1 := by rw [ht12] cases hcase : (cutMatching F κ o).tail ⟨i₁, hb₁⟩ - · rw [if_neg (by simp), Bool.not_false, if_pos rfl] + · 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 [if_pos rfl, Bool.not_true, if_neg (by simp)] + · 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 @@ -1240,7 +1240,7 @@ theorem tFull_portFlip_all [LinearOrder α] [Fintype α] {W : Fragment α} · exact hnt₁ (hx' ▸ hit) · exact hnt₂ (hx' ▸ hit) simp only [untwist] - rw [dif_pos hbi, dif_pos hbi, + 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' @@ -1348,7 +1348,7 @@ theorem tFullD_congr_through [LinearOrder α] [Fintype α] {W : Fragment α} · exact hthr₁ · exact hthr₂ · refine hthr b ?_ - rwa [DirMatching.reverseArc_tail, if_neg hbm] at hb + 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] @@ -1418,8 +1418,8 @@ theorem partner_of_throughAgree [LinearOrder α] {W : Fragment α} cases hb : M.tail a with | false => rw [hb] at hs hs' - simp only [Bool.false_eq_true, if_false, Bool.not_false, - if_true] 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' @@ -1429,8 +1429,8 @@ theorem partner_of_throughAgree [LinearOrder α] {W : Fragment α} rw [← hd, oddPartner_invol ℓ] | true => rw [hb] at hs hs' - simp only [if_true, Bool.not_true, Bool.false_eq_true, - if_false] at hs hs' + simp only [ite_true, Bool.not_true, Bool.false_eq_true, + ite_false] at hs hs' rw [hs', ← hs] rfl @@ -1487,12 +1487,12 @@ theorem throughAgree_of_partner [LinearOrder α] {W : Fragment α} 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, if_false, Bool.not_false, - if_true, Sum.map_inr, oddPartner_invol] at hs hs' + 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, if_true, Bool.not_true, Bool.false_eq_true, - if_false, Sum.map_inr] at hs hs' + 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 @@ -1730,13 +1730,13 @@ theorem exists_eulerianPosition {t : ℕ} {W₁ W₂ : Fragment (Fin t)} ((cutMatching F₂ κ₂ o₂).map e.symm) refine ⟨A, B.map e, fun a => ?_, fun b => ?_, fun a => ?_⟩ · exact congrArg Subtype.val (congrFun hAe a) - · show (e (B.edge (e.symm b))).val = _ + · change (e (B.edge (e.symm b))).val = _ rw [congrFun hBe (e.symm b)] - show (e (e.symm ((cutMatching F₂ κ₂ o₂).edge + change (e (e.symm ((cutMatching F₂ κ₂ o₂).edge (e (e.symm b))))).val = _ rw [e.apply_symm_apply, e.apply_symm_apply] rfl - · show B.tail (e.symm (e a)) = _ + · change B.tail (e.symm (e a)) = _ rw [e.symm_apply_apply] exact hAB a @@ -1804,11 +1804,11 @@ theorem exists_sum_sum_superForm_tFull {t : ℕ} 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 - show (if hb : W₂.boundaryFlag i ∈ F₂.boundaryFlags then + 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 [dif_pos hi₂, dif_pos hi] + rw [dite_eq_left hi₂, dite_eq_left hi] exact halt ⟨i, hi⟩ /-! ### The fragment's tensor diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelTransition.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelTransition.lean index a4840980a3..ee3dc3edc8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelTransition.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelTransition.lean @@ -49,7 +49,7 @@ degenerates to `TransitionSystem` and `internalCircuitCount` equals namespace RS -open scoped Classical + variable {α : Type} @@ -59,11 +59,13 @@ 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} : @@ -71,11 +73,13 @@ theorem mem_internalFlags_iff {f : W.Flag} {F : EdgeSubset W} : ∃ 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) : @@ -87,26 +91,31 @@ theorem mem_internalFlags_or_boundaryFlags (F : EdgeSubset W) /-- 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 := @@ -157,6 +166,7 @@ structure RelTransitionSystem (F : EdgeSubset W) where /-! ## 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} @@ -164,6 +174,7 @@ theorem mem_internalFlags_of {F : EdgeSubset W} {f : W.Flag} 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 @@ -262,6 +273,7 @@ noncomputable def RelTransitionSystem.internalCircuitCount /-! ## 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} @@ -302,7 +314,7 @@ theorem walkPerm_eq_of_transition {F : EdgeSubset W} ((flagsEquivInternal κ).permCongr κ.walkPerm ⟨f, hf⟩).val simp only [RelTransitionSystem.walkPermInternal, Equiv.ofBijective_apply, Equiv.permCongr_apply, flagsEquivInternal] - show κ.match_ (W.pairing f) = κ.walk f + change κ.match_ (W.pairing f) = κ.walk f rfl /-- **Compatibility**: for a closed-fragment transition system, diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelValue.lean index ee9751b2d9..a26281a452 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelValue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelValue.lean @@ -42,8 +42,8 @@ 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 - letI := W.flagOrder - letI := Classical.dec + 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 @@ -68,8 +68,8 @@ theorem mem_relInFlagsAt_iff {F : EdgeSubset W} f ∈ F.relInFlagsAt o vv ↔ f ∈ F.flags ∧ W.attach f = Sum.inl vv ∧ o.isOut f = false := by - letI := W.flagOrder - letI := Classical.dec + let := W.flagOrder + let := Classical.dec unfold EdgeSubset.relInFlagsAt rw [Finset.mem_sort, Finset.mem_filter] @@ -78,8 +78,8 @@ theorem relInFlagsAt_nodup {F : EdgeSubset W} {κ : F.RelTransitionSystem} (o : κ.Orientation) (vv : W.Vertex) : (F.relInFlagsAt o vv).Nodup := by - letI := W.flagOrder - letI := Classical.dec + let := W.flagOrder + let := Classical.dec unfold EdgeSubset.relInFlagsAt exact Finset.sort_nodup _ _ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelChords.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelChords.lean index 61e042b96b..cec80e4e23 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelChords.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelChords.lean @@ -18,7 +18,7 @@ and `e` preserves the sorting. namespace RS -open scoped Classical + open EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelInvariance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelInvariance.lean index 5f8a366e56..db89654a03 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelInvariance.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelInvariance.lean @@ -27,7 +27,7 @@ the other's, and the conversions are identity-shaped. namespace RS -open scoped Classical + section General @@ -41,13 +41,13 @@ 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 - show (W.attach f).map id ⇑ee = Sum.inl v ↔ W.attach f = Sum.inl v + 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 - show (W.attach f).map id ⇑ee = Sum.inr (ee i) ↔ W.attach f = Sum.inr i + 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. -/ @@ -79,7 +79,7 @@ private theorem filter_eq_of_iff {γ : Type} {p q : γ → Prop} /-- The relabelled boundary flag at a pushed-forward label. -/ theorem relabel_boundaryFlag_apply (a : α) : (W.relabel ee).boundaryFlag (ee a) = W.boundaryFlag a := by - show W.boundaryFlag (ee.symm (ee a)) = W.boundaryFlag a + change W.boundaryFlag (ee.symm (ee a)) = W.boundaryFlag a rw [Equiv.symm_apply_apply] /-! ## Edge subsets under a relabel -/ @@ -213,7 +213,7 @@ theorem relabel_iterWalk (F : EdgeSubset W) (κ : F.RelTransitionSystem) induction n with | zero => rfl | succ n ih => - show (relabelTransUp ee F κ).match_ ((W.relabel ee).pairing + 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] @@ -317,8 +317,8 @@ theorem relabel_relInFlagsAt (F : EdgeSubset W) (F.relabelUp ee).relInFlagsAt (relabelOrientUp ee F o) v = F.relInFlagsAt o v := by unfold EdgeSubset.relInFlagsAt - letI := (W.relabel ee).flagOrder - letI := Classical.dec + 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 => @@ -490,7 +490,7 @@ theorem relabel_throughProduct (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] - show (if e.toEquiv i₀ < e.toEquiv j₀ then + 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₀)) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RepairInvariance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RepairInvariance.lean index d4ff96d3c1..c315e69ffb 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RepairInvariance.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RepairInvariance.lean @@ -51,7 +51,7 @@ the boundary pairing's chord sign. namespace RS -open scoped Classical + /-! ## List helpers -/ @@ -305,8 +305,8 @@ 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 - letI := W.flagOrder - letI := Classical.dec + 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) = @@ -446,7 +446,7 @@ theorem walkPermPeriodic_matchEq {κ₁ κ₂ : F.RelTransitionSystem} have hpint : W.pairing f ∈ F.internalFlags := by have h0 := all_pairings_internal_of_periodic κ₂ hper₂ 0 simpa using h0 - show κ₂.match_ (W.pairing f) = _ + change κ₂.match_ (W.pairing f) = _ exact (heq _ hpint).symm.trans rfl /-- **Matching-equal systems have equal open circuit counts.** -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidInstance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidInstance.lean index 881d750dd7..16937da214 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidInstance.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidInstance.lean @@ -24,6 +24,7 @@ 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidityClasses.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidityClasses.lean index 109d757eee..1d2230b75b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidityClasses.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidityClasses.lean @@ -28,12 +28,12 @@ noncomputable def strandRelabelEquiv (e : Fin 2 ≃ Fin 2) : flagEquiv := e vertexEquiv := _root_.Equiv.refl Empty attach_comm := fun g => by - show Sum.inr (e g) = + change Sum.inr (e g) = ((Sum.inr (e g) : Empty ⊕ Fin 2).map (_root_.Equiv.refl Empty) id) rfl pairing_comm := fun g => by - show e ⟨1 - g.val, by omega⟩ = ⟨1 - (e g).val, by omega⟩ + 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 @@ -46,7 +46,7 @@ noncomputable def strandRelabelEquiv (e : Fin 2 ≃ Fin 2) : have h1 : (e x).val < 2 := (e x).isLt have h2 : (e g).val < 2 := (e g).isLt refine Fin.ext ?_ - show (e x).val = 1 - (e g).val + change (e x).val = 1 - (e g).val omega circles_eq := rfl diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarClass.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarClass.lean index 9e4fea6355..e57739591f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarClass.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarClass.lean @@ -40,7 +40,7 @@ theorem ofFragment_eq_smul_empty {R : ℕ} LinearMap.ker (connectionMap f.val 0) := by rw [LinearMap.mem_ker, map_sub, map_smul] funext G - show connectionMap f.val 0 (Finsupp.single W 1) 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, diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SeparatedParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SeparatedParity.lean index 38fab6599e..e7e55af08b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SeparatedParity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SeparatedParity.lean @@ -50,7 +50,7 @@ moves by exactly `±2`, i.e. the circuit count by `±1`. namespace RS -open scoped Classical + /-! ## (i) Abstract orbit counting -/ @@ -788,7 +788,7 @@ theorem fullMatchFun_val_internal (κ : F.RelTransitionSystem) (h : x.val ∈ F.internalFlags) : (fullMatchFun κ x).val = κ.match_ x.val := by unfold fullMatchFun - rw [dif_pos h] + rw [dite_eq_left h] /-- And the path matching on boundary flags: this is what closes the chains into orbits. -/ @@ -800,7 +800,7 @@ theorem fullMatchFun_val_boundary (κ : F.RelTransitionSystem) Finset.disjoint_right.mp F.internalFlags_disjoint_boundaryFlags h unfold fullMatchFun - rw [dif_neg hni] + rw [dite_eq_right hni] /-- The full matching is an involution, both halves being ones. -/ theorem fullMatchFun_invol (κ : F.RelTransitionSystem) @@ -1078,7 +1078,7 @@ theorem not_sameCycle_pairingPermSP_of_chain {f : W.Flag} (fullPerm κ ^ t) ⟨β, mem_flags_of_boundaryFlags F hβ⟩ := by refine Subtype.ext ?_ rw [fullPerm_pow_val hcont t htk, pairingPermSP_val] - show W.pairing f = iterWalk κ β t + change W.pairing f = iterWalk κ β t rw [hf1, W.pairing_invol] have hbσ : (fullPerm κ).SameCycle ⟨β, mem_flags_of_boundaryFlags F hβ⟩ @@ -1178,7 +1178,7 @@ theorem fullPerm_periodic_iff (x : {f : W.Flag // f ∈ F.flags}) : have h1 : ((fullPerm κ)⁻¹ (fullPerm κ x)).val = W.pairing (κ.match_ ((fullPerm κ x).val)) := by rw [fullPerm_inv] - show (pairingPermSP F + change (pairingPermSP F (fullMatchPerm κ (fullPerm κ x))).val = _ rw [pairingPermSP_val, fullMatchPerm_apply, fullMatchFun_val_internal κ hzint] @@ -1260,7 +1260,7 @@ theorem walkPermPeriodic_eq_permCongr : have h0 := all_pairings_internal_of_periodic κ ((κ.mem_periodicFlags).mp f.prop) 0 rwa [iterWalk_zero] at h0 - show κ.internalWalk f.val = + change κ.internalWalk f.val = ((fullPerm κ) ⟨f.val, mem_flags_of_internalFlags F (κ.periodicFlags_sub f.prop)⟩).val rw [fullPerm_val_internal hσ] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCategory.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCategory.lean index 1b95d74025..93d800c62b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCategory.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCategory.lean @@ -32,7 +32,7 @@ theorem mem_ker_single_sub_of_equiv {t : ℕ} LinearMap.ker (connectionMap f.val t) := by rw [LinearMap.mem_ker, map_sub] funext K - show connectionMap f.val t (Finsupp.single F 1) 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, diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdeal.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdeal.lean index 0e9b38ed99..66e23a5286 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdeal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdeal.lean @@ -85,7 +85,7 @@ theorem connectionMap_compose_single rfl | add y z hy hz => rw [map_add, LinearMap.add_apply, map_add] - show connectionMap f (m + p) _ K + connectionMap f (m + p) _ K + change connectionMap f (m + p) _ K + connectionMap f (m + p) _ K = _ rw [hy, hz, map_add] rfl diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdealLeft.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdealLeft.lean index cc138faa2e..609e7c049a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdealLeft.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdealLeft.lean @@ -53,7 +53,7 @@ theorem connectionMap_compose_left_single rfl | add y z hy hz => rw [map_add, map_add] - show connectionMap f (s + u) _ K + + change connectionMap f (s + u) _ K + connectionMap f (s + u) _ K = _ rw [hy, hz, map_add] rfl diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarDecomposition.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarDecomposition.lean index 1b8daa0493..746af7f884 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarDecomposition.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarDecomposition.lean @@ -177,20 +177,20 @@ noncomputable def explodeAtNotMem (C : Finset W.Flag) {f : W.Flag // f ∈ C}).symm vertexEquiv := _root_.Equiv.refl W.Vertex attach_comm := fun f => by - show (explodeAt W C hC).attach (Sum.inl f) = + 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 - show (Sum.inl (W.pairing f) : + 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 - show (if h : g ∈ C then + 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 dif_neg (hne g) + exact dite_eq_right (hne g) rw [hp f] circles_eq := rfl } @@ -209,10 +209,10 @@ theorem explode_reglue : have hne : ∀ f, f ∉ C := fun f hf => by obtain ⟨x, hx, _⟩ := hcov f hf exact absurd hx (List.not_mem_nil) - haveI : IsEmpty {f : W.Flag // f ∈ C} := + have : IsEmpty {f : W.Flag // f ∈ C} := ⟨fun s => hne s.val s.prop⟩ refine ⟨?_⟩ - show ((explodeAt W C hC).relabel + change ((explodeAt W C hC).relabel Fragment.foldSurvivingNilEquiv.symm).Equiv (W.relabel e) refine (Fragment.Equiv.relabelCongr (explodeAtNotMem W C hC hne @@ -243,7 +243,7 @@ theorem explode_reglue : (cutErase_closed W C hC x) l h') := mapPairs_wf_of (stepLabelEquiv W C hC x hx) (hco ▸ wfco) - haveI : IsEmpty (Fragment.FoldSurviving + 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')) := @@ -253,7 +253,7 @@ theorem explode_reglue : (cutErase_closed W C hC x) h' hcov' wf' (_root_.Equiv.equivOfIsEmpty (Fin 0) _) refine ⟨?_⟩ - show (Fragment.glueList (explodeAt W C hC) + 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) @@ -329,7 +329,7 @@ theorem repPairs_wf_of (C : Finset W.Flag) (hC : CutClosed W C) : | x :: l, h, hnodup, hdisj => by have htail : ∀ y ∈ l, y ∈ C := fun y hy => h y (List.mem_cons.mpr (Or.inr hy)) - show ((⟨x, _⟩, ⟨W.pairing x, _⟩) :: + change ((⟨x, _⟩, ⟨W.pairing x, _⟩) :: repPairs W C hC l htail).flatMap (fun p => [p.1, p.2]) |>.Nodup rw [List.flatMap_cons] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarEnum.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarEnum.lean index 8da046bad5..07479c4e23 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarEnum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarEnum.lean @@ -76,20 +76,20 @@ noncomputable def repSplitEquiv : invFun := repSplitInv W left_inv f := by by_cases h : f ∈ canonicalReps W - · have h1 : repSplitFun W f = Sum.inl ⟨f, h⟩ := dif_pos h + · 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⟩ := dif_neg h + (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 - · show repSplitFun W x.val = Sum.inl x - exact dif_pos x.prop - · show repSplitFun W (W.pairing x.val) = Sum.inr x - exact (dif_neg (pairing_notMem_canonicalReps W x.prop)).trans + · 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. -/ @@ -153,11 +153,11 @@ theorem starEnum_rep (j : ℕ) (hj : j < (canonicalReps W).length) : Fin.castAdd (edgeCount W) ⟨j, hj⟩ := by have hmem : (canonicalReps W)[j]'hj ∈ canonicalReps W := List.getElem_mem hj - show finSumFinEquiv + 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⟩ := dif_pos hmem + 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 @@ -181,13 +181,13 @@ theorem starEnum_partner (j : ℕ) have hnot : W.pairing ((canonicalReps W)[j]'hj) ∉ canonicalReps W := pairing_notMem_canonicalReps W hmem - show finSumFinEquiv + 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⟩ := - dif_neg 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)), @@ -198,7 +198,7 @@ theorem starEnum_partner (j : ℕ) List.Nodup.getEquiv (canonicalReps W) (canonicalReps_nodup W) ⟨j, hj⟩ from Subtype.ext (by - show W.pairing (W.pairing ((canonicalReps W)[j]'hj)) = _ + change W.pairing (W.pairing ((canonicalReps W)[j]'hj)) = _ rw [W.pairing_invol] rfl)] exact Equiv.symm_apply_apply _ _ @@ -224,7 +224,7 @@ theorem repPairs_getElem (C : Finset W.Flag) (hC : CutClosed W C) : | [], _, j, hj, _ => absurd hj (by simp [repPairs]) | x :: l, h, 0, _, _ => rfl | x :: l, h, j + 1, hj, hj' => by - show (repPairs W C hC l _)[j]'_ = _ + 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. -/ @@ -275,7 +275,7 @@ theorem starUnion_surv_isEmpty : (repPairs W Finset.univ (fullCut_closed W) (canonicalReps W) (fun _ _ => Finset.mem_univ _)) rw [mapPairs_repPairs W] at e - haveI := canonical_surv_isEmpty W + have := canonical_surv_isEmpty W exact Function.isEmpty e.symm /-- **The star union self-glue**: gluing the straight matching in @@ -286,7 +286,7 @@ theorem starUnion_reglue : (W.relabel (haveI := starUnion_surv_isEmpty W Equiv.equivOfIsEmpty (Fin 0) _))) := by - haveI := starUnion_surv_isEmpty W + have := starUnion_surv_isEmpty W obtain ⟨D⟩ := starDecomposition W have G := Fragment.glueListRelabel (explodeAt W Finset.univ (fullCut_closed W)) (starEnum W) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarExplode.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarExplode.lean index 87e8349896..54e4ac6c78 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarExplode.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarExplode.lean @@ -68,20 +68,20 @@ def explodeAt (W : ClosedFragment) (C : Finset W.Flag) pairing_invol := fun g => by rcases g with f | s · by_cases h : f ∈ C - · simp only [dif_pos h] - · simp only [dif_neg h, - dif_neg (fun hp => h (hC.pairing_mem.mp hp)), + · 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 [dif_pos s.prop] + · 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 [dif_pos hf] at h' + · rw [dite_eq_left hf] at h' exact Sum.inr_ne_inl h' - · rw [dif_neg hf] at 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 @@ -190,6 +190,175 @@ def stepFlagEquiv : · 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. -/ @@ -213,7 +382,7 @@ noncomputable def explodeAtGluePair (W : ClosedFragment) (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 := - dif_neg hopen + dite_eq_right hopen rw [heq] exact { flagEquiv := stepFlagEquiv W C hC f₀ h₀ @@ -226,166 +395,7 @@ noncomputable def explodeAtGluePair (W : ClosedFragment) · rfl · rfl -- ═══════ PAIRING ═══════ - pairing_comm := fun g => by - obtain ⟨gv, hg⟩ := g - rcases gv with f | s - · -- ═══════ An old flag: case-split on the rewire ═══════ - show (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 [dif_pos 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) := dif_neg 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 - show (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 [dif_neg hne₀] - · rw [dif_neg 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 [dif_pos 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 - show (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 [dif_neg hne₁, W.pairing_invol] - · rw [dif_neg 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 [dif_pos 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 dif_pos 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 - dif_pos hmem) - simp only [hp₁] - exact hp₂.symm - · -- f ∉ C → pairing = Sum.inl (W.pairing f) - rw [dif_neg 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 dif_neg 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 dif_neg hne) - simp only [hp₁] - exact hp₂.symm - · -- ═══════ A new star flag ═══════ - show (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 + pairing_comm := explodeAt_rewire_pairing W C hC f₀ h₀ hopen } end GlueStep diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarPrep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarPrep.lean index 0bcba6ce3b..071dfe4d10 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarPrep.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarPrep.lean @@ -41,14 +41,14 @@ theorem mem_matchPairs_flat (m : ℕ) (z : Fin (m + m)) : · 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 ?_))))⟩ - show z.val = m + (z.val - m) + 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 - show ((matchPairs m).flatMap (fun p => [p.1, p.2])).Nodup + change ((matchPairs m).flatMap (fun p => [p.1, p.2])).Nodup rw [matchPairs_flat] refine List.nodup_flatMap.mpr ⟨?_, ?_⟩ · intro j _ @@ -115,16 +115,16 @@ noncomputable def strandBundleTranspose (m : ℕ) : vertexEquiv := _root_.Equiv.refl Empty attach_comm := fun f => by obtain ⟨i, b⟩ := f - show (strandBundle m).attach (i, !b) = + change (strandBundle m).attach (i, !b) = (((strandBundle m).attach (i, b)).map id (transposeEquiv m m)).map (_root_.Equiv.refl Empty) id cases b - · show (Sum.inr ⟨m + i.val, by omega⟩ : + · 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] - · show (Sum.inr ⟨i.val, by omega⟩ : + · 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 ?_ @@ -187,9 +187,9 @@ theorem interfacePairs_split (m : ℕ) : rw [hR] refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) (congrArg Sum.inr (Fin.ext ?_)) - · show 0 + (m + m - 1 - i) = m + (m - 1 - i) + · change 0 + (m + m - 1 - i) = m + (m - 1 - i) omega - · show m + m - 1 - i = m + (m - 1 - i) + · 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, @@ -215,9 +215,9 @@ theorem interfacePairs_split (m : ℕ) : rw [hR] refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) (congrArg Sum.inr (Fin.ext ?_)) - · show 0 + (m + m - 1 - i) = m - 1 - (i - m) + · change 0 + (m + m - 1 - i) = m - 1 - (i - m) omega - · show m + m - 1 - i = m - 1 - (i - m) + · change m + m - 1 - i = m - 1 - (i - m) omega end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StateFlipSet.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StateFlipSet.lean index c800b20c02..8839db04fb 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StateFlipSet.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StateFlipSet.lean @@ -17,7 +17,7 @@ accumulations cancel by parity. namespace RS -open scoped Classical + variable {k ℓ : ℕ} {α : Type} @@ -33,32 +33,32 @@ variable {st : GenBoundaryState k ℓ α} theorem stateOddFlipSet_of_mem {E : Finset α} {i : α} (h : i ∈ E) : stateOddFlipSet st E i = Sum.map id (oddPartner ℓ) (st i) := - if_pos h + 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 := - if_neg h + ite_eq_right h /-- The empty relabel is the identity. -/ theorem stateOddFlipSet_empty : stateOddFlipSet st (∅ : Finset α) = st := by funext i - exact if_neg (Finset.notMem_empty i) + exact ite_eq_right (Finset.notMem_empty i) /-- 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 - show (if i = i₁ ∨ i = i₂ then Sum.map id (oddPartner ℓ) (st 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 [if_pos h, if_pos (by + · 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 [if_neg h, if_neg (by + · 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) @@ -73,20 +73,20 @@ theorem stateOddFlipSet_flipSet (E₁ E₂ : Finset α) : funext i unfold stateOddFlipSet by_cases h1 : i ∈ E₁ <;> by_cases h2 : i ∈ E₂ - · rw [if_pos h2, if_pos h1, if_neg (by + · 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 - · show Sum.inr (oddPartner ℓ (oddPartner ℓ c)) = Sum.inr c + · change Sum.inr (oddPartner ℓ (oddPartner ℓ c)) = Sum.inr c rw [oddPartner_invol] - · rw [if_neg h2, if_pos h1, if_pos + · rw [ite_eq_right h2, ite_eq_left h1, ite_eq_left (Finset.mem_union_left _ (Finset.mem_sdiff.mpr ⟨h1, h2⟩))] - · rw [if_pos h2, if_neg h1, if_pos + · rw [ite_eq_left h2, ite_eq_right h1, ite_eq_left (Finset.mem_union_right _ (Finset.mem_sdiff.mpr ⟨h2, h1⟩))] - · rw [if_neg h2, if_neg h1, if_neg (by + · 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StatusSet.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StatusSet.lean index 4c1a16b474..cb5cd5bd26 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StatusSet.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StatusSet.lean @@ -20,7 +20,7 @@ when the pairing returns. namespace RS -open scoped Classical + variable {α : Type} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepFrame.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepFrame.lean index 9d2e2a3a78..0520113041 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepFrame.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepFrame.lean @@ -21,7 +21,7 @@ system. namespace RS -open scoped Classical + variable {α : Type} @@ -346,20 +346,20 @@ theorem antiLowSet_transport_eq rcases Finset.mem_insert.mp hx4 with rfl | hx4b · obtain ⟨hlt, hhigh⟩ := hm₁.mp hx left - rw [if_pos (by rw [if_pos hlt]; exact hhigh)] - rw [Finset.mem_singleton, newLow, if_pos hlt] + 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 [if_pos (by rw [if_neg hnlt]; exact hhigh)] - rw [Finset.mem_singleton, newLow, if_neg hnlt] + 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 [if_pos (by rw [if_pos hlt]; exact hhigh)] - rw [Finset.mem_singleton, newLow, if_pos hlt] + 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 @@ -367,8 +367,8 @@ theorem antiLowSet_transport_eq have hnlt : ¬ F.boundaryLabel (κ.pathMatch_mem he₁) < F.boundaryLabel (κ.pathMatch_mem he₂) := fun h => lt_asymm h hlt - rw [if_pos (by rw [if_neg hnlt]; exact hhigh)] - rw [Finset.mem_singleton, newLow, if_neg hnlt] + 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₁ < @@ -378,21 +378,21 @@ theorem antiLowSet_transport_eq else F.boundaryLabel (κ.pathMatch_mem he₂) < F.boundaryLabel he₂) - · rw [if_pos hcond, Finset.mem_singleton] at hx + · rw [ite_eq_left hcond, Finset.mem_singleton] at hx subst hx unfold newLow by_cases hlt : F.boundaryLabel he₁ < F.boundaryLabel he₂ - · rw [if_pos hlt] - rw [if_pos hlt] at hcond + · rw [ite_eq_left hlt] + rw [ite_eq_left hlt] at hcond exact hm₁.mpr ⟨hlt, hcond⟩ - · rw [if_neg hlt] - rw [if_neg hlt] at 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 [if_neg hcond] at hx + · rw [ite_eq_right hcond] at hx exact absurd hx (Finset.notMem_empty _) · by_cases hcond : (if F.boundaryLabel (κ.pathMatch_mem he₁) < @@ -402,22 +402,22 @@ theorem antiLowSet_transport_eq else F.boundaryLabel he₂ < F.boundaryLabel (κ.pathMatch_mem he₂)) - · rw [if_pos hcond, Finset.mem_singleton] at hx + · 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 [if_pos hlt] - rw [if_pos hlt] at hcond + · rw [ite_eq_left hlt] + rw [ite_eq_left hlt] at hcond exact hm₃.mpr ⟨hlt, hcond⟩ - · rw [if_neg hlt] - rw [if_neg hlt] at 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 [if_neg hcond] at hx + · rw [ite_eq_right hcond] at hx exact absurd hx (Finset.notMem_empty _) /-- **The flip count of a separated canonical step**: the four-label diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepLedger.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepLedger.lean index 3ce013ff4b..3381e18d5c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepLedger.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepLedger.lean @@ -65,7 +65,7 @@ is treated as one composite move. namespace RS -open scoped Classical + namespace EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatus.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatus.lean index de6ce4b27c..4071b4d79d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatus.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatus.lean @@ -27,7 +27,7 @@ on a re-paired end (`mem_highSet_repair_untouched`). namespace RS -open scoped Classical + /-! ## Propositional inequality helpers -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatusNonsep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatusNonsep.lean index 56b8427018..b3dd7e4975 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatusNonsep.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatusNonsep.lean @@ -39,7 +39,7 @@ transported frame of *any* repair from a canonical source. namespace RS -open scoped Classical + /-! ## Propositional XOR helpers -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StrandBundle.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StrandBundle.lean index acfc075286..222bdb8b63 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StrandBundle.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StrandBundle.lean @@ -35,24 +35,24 @@ def strandBundle (t : ℕ) : Fragment (Fin (t + t)) where else (⟨ℓ.val - t, by omega⟩, true) attach_boundaryFlag := fun ℓ => by by_cases h : ℓ.val < t - · rw [dif_pos h] + · rw [dite_eq_left h] exact congrArg Sum.inr (Fin.ext rfl) - · rw [dif_neg h] + · rw [dite_eq_right h] refine congrArg Sum.inr (Fin.ext ?_) - show t + (ℓ.val - t) = ℓ.val + 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, if_false] at hℓ + · simp only [Bool.false_eq_true, ite_false] at hℓ subst hℓ - rw [dif_pos a.isLt] - · simp only [if_true] at hℓ + rw [dite_eq_left a.isLt] + · simp only [ite_true] at hℓ subst hℓ - rw [dif_neg (show ¬ t + a.val < t by omega)] + rw [dite_eq_right (show ¬ t + a.val < t by omega)] refine Prod.ext_iff.mpr ⟨Fin.ext ?_, rfl⟩ - show a.val = t + a.val - t + change a.val = t + a.val - t omega circles := 0 @@ -60,13 +60,13 @@ def strandBundle (t : ℕ) : Fragment (Fin (t + t)) where theorem strandBundle_boundaryFlag_low (t : ℕ) (ℓ : Fin (t + t)) (h : ℓ.val < t) : (strandBundle t).boundaryFlag ℓ = (⟨ℓ.val, h⟩, false) := by - simp only [strandBundle, dif_pos h] + 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, dif_neg h] + 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 index 0dfcc418d0..4f4ce5030d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SumLexOrder.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SumLexOrder.lean @@ -24,6 +24,7 @@ namespace RS -- 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) @@ -37,7 +38,7 @@ theorem sumLex_inl_lt_inl_iff [LinearOrder α] [LinearOrder β] {a a' : α} : (sumLexLinearOrder α β).lt (Sum.inl a) (Sum.inl a') ↔ a < a' := by - show toLex (Sum.inl a) < toLex (Sum.inl a') ↔ _ + change toLex (Sum.inl a) < toLex (Sum.inl a') ↔ _ exact Sum.Lex.inl_lt_inl_iff /-- Within the right block, the right order. -/ @@ -45,21 +46,21 @@ theorem sumLex_inr_lt_inr_iff [LinearOrder α] [LinearOrder β] {b b' : β} : (sumLexLinearOrder α β).lt (Sum.inr b) (Sum.inr b') ↔ b < b' := by - show toLex (Sum.inr b) < toLex (Sum.inr b') ↔ _ + 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 - show toLex (Sum.inl a) < toLex (Sum.inr b) + 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 - show ¬ toLex (Sum.inr b) < toLex (Sum.inl a) + 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 _) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperGram.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperGram.lean index 0664034e91..fa6b9fb167 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperGram.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperGram.lean @@ -25,7 +25,7 @@ because that is how many boundary states there are. namespace RS -open Classical + /-- **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 @@ -165,23 +165,23 @@ theorem superLeg_eq_zero_of_ne_dualLeg {k ℓ : ℕ} superLeg u v = 0 := by rcases u with a | c · rcases v with b | d - · exact if_neg (fun hb => h (by rw [hb]; rfl)) + · exact ite_eq_right (fun hb => h (by rw [hb]; rfl)) · rfl · rcases v with b | d · rfl - · show symplecticJ ℓ c d = 0 + · 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 [if_pos hlt] at hpart - rw [if_neg (fun hx => hd (hpart.mpr hx)), - if_neg (by omega)] - · rw [if_neg hlt] at hpart - rw [if_neg (by omega), - if_neg (fun hx => hd (hpart.mpr (by omega)))] + · 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 : ℕ} @@ -205,8 +205,8 @@ noncomputable def legSelf {k ℓ : ℕ} : theorem superLeg_dualLeg {k ℓ : ℕ} (u : Fin k ⊕ Fin (2 * ℓ)) : superLeg u (dualLeg u) = legSelf u := by rcases u with a | c - · exact if_pos rfl - · show symplecticJ ℓ c (oddPartner ℓ c) = -dualSign ℓ 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 @@ -259,23 +259,23 @@ theorem legBracket_odd {k ℓ : ℕ} (u : Fin (2 * ℓ)) (t₁ : Bool) : (Sum.inr (oddPartner ℓ u))) = -dualSign ℓ u := by have hfg := superLeg_f_g ℓ u have hsq := dualSign_sq ℓ u - show symplecticJ ℓ u (oddPartner ℓ u) = -dualSign ℓ 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 [if_neg (by simp), Bool.not_false, if_pos rfl, hJ, hpart, - if_neg (by simp)] + · rw [ite_eq_right (by simp), Bool.not_false, ite_eq_left rfl, hJ, hpart, + ite_eq_right (by simp)] linear_combination hsq - · rw [if_pos rfl, Bool.not_true, if_neg (by simp), hJ, - if_pos rfl] + · 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 := - if_pos rfl + ite_eq_left rfl /-! ### The legs, multiplied out @@ -315,22 +315,22 @@ theorem legWeight_mul {k ℓ : ℕ} (b : Bool) 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 [if_neg (by + · rw [ite_eq_right (by rintro ⟨⟨c, hcc⟩, -⟩ exact Sum.inl_ne_inr hcc)] - show (1 : ℂ) * 1 * superLeg (Sum.inl a) (Sum.inl a) = 1 + 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 [if_pos ⟨⟨u, rfl⟩, hbt⟩, hbt] + · 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 [if_neg (fun hc => hbt hc.2), hbf] + rw [ite_eq_right (fun hc => hbt hc.2), hbf] rw [hbf] at hb simpa [legWeight, dualLeg] using hb @@ -346,7 +346,7 @@ theorem dualLeg_involutive {k ℓ : ℕ} : Function.Involutive (dualLeg (k := k) (ℓ := ℓ)) := by rintro (a | c) · rfl - · show Sum.inr (oddPartner ℓ (oddPartner ℓ c)) = Sum.inr c + · change Sum.inr (oddPartner ℓ (oddPartner ℓ c)) = Sum.inr c rw [oddPartner_invol] /-- **Undoing the dual basis at the legs whose arc leaves.** -/ @@ -360,15 +360,15 @@ theorem untwistState_involutive {k ℓ t : ℕ} (b : Fin t → Bool) : Function.Involutive (untwistState (k := k) (ℓ := ℓ) b) := by intro x funext i - show (if b i then dualLeg (untwistState b x 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 [if_pos hb] - show dualLeg (if b i then dualLeg (x i) else x i) = x i - rw [if_pos hb, dualLeg_involutive (x i)] - · rw [if_neg hb] - show (if b i then dualLeg (x i) else x i) = x i - rw [if_neg hb] + · 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) @@ -383,7 +383,7 @@ theorem sum_untwistState {k ℓ t : ℕ} (b : Fin t → Bool) 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 - show (∃ c, dualLeg (x i) = Sum.inr c) ↔ (∃ c, x i = Sum.inr c) + change (∃ c, dualLeg (x i) = Sum.inr c) ↔ (∃ c, x i = Sum.inr c) rcases x i with a | c · constructor · rintro ⟨d, hd⟩ @@ -400,29 +400,29 @@ theorem untwistState_dualState' {k ℓ t : ℕ} (b₁ b₂ : Fin t → Bool) (hb : ∀ i, (∃ c, x i = Sum.inr c) → b₂ i = !(b₁ i)) : untwistState b₂ (dualState x) = untwistState b₁ x := by funext i - show (if b₂ i then dualLeg (dualLeg (x i)) else dualLeg (x 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 [if_pos h₂] + · rw [ite_eq_left h₂] by_cases h₁ : b₁ i = true - · rw [if_pos h₁] - · rw [if_neg h₁] - · rw [if_neg h₂] + · rw [ite_eq_left h₁] + · rw [ite_eq_right h₁] + · rw [ite_eq_right h₂] by_cases h₁ : b₁ i = true - · rw [if_pos h₁] - · rw [if_neg h₁] + · 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, if_neg (by simp), if_pos rfl] + · 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, if_pos rfl, if_neg (by simp)] + rw [hf, Bool.not_false, ite_eq_left rfl, ite_eq_right (by simp)] exact dualLeg_involutive _ /-! ### Contracting one leg @@ -446,7 +446,7 @@ theorem prod_legBracket {k ℓ t : ℕ} classical rw [superForm, ← Finset.prod_mul_distrib, ← Finset.prod_mul_distrib] rw [Finset.prod_congr rfl (fun i _ => by - show legWeight (b i) (x i) * legWeight (!(b i)) (dualLeg (x i)) + 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, @@ -467,7 +467,7 @@ theorem oddCount_dualState {k ℓ t : ℕ} · exact ⟨u, rfl⟩ · rintro ⟨u, hu⟩ exact ⟨oddPartner ℓ u, by - show dualLeg (x i) = Sum.inr (oddPartner ℓ u) + change dualLeg (x i) = Sum.inr (oddPartner ℓ u) rw [hu] rfl⟩ @@ -560,7 +560,7 @@ theorem sum_legBracket_with_twists' {k ℓ t : ℕ} 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 - show (∃ c, dualLeg (x i) = Sum.inr c) ↔ (∃ c, x i = Sum.inr c) + change (∃ c, dualLeg (x i) = Sum.inr c) ↔ (∃ c, x i = Sum.inr c) rcases x i with a | c · constructor · rintro ⟨d, hd⟩ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperSpace.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperSpace.lean index bf2f4d2389..21d8c23eb2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperSpace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperSpace.lean @@ -29,7 +29,7 @@ the tower's colour kernel, which pairs the odd colours through namespace RS -open Classical + /-- **The symplectic matrix** `J = [[0, I], [-I, 0]]` in coordinates: `J c d` is `1` when `d = c + ℓ`, `-1` when @@ -60,8 +60,8 @@ theorem eq_oddPartner_iff {ℓ : ℕ} (c d : Fin (2 * ℓ)) : ↔ (if c.val < ℓ then d.val = c.val + ℓ else d.val = c.val - ℓ) := by unfold oddPartner by_cases h : c.val < ℓ - · rw [dif_pos h, if_pos h, Fin.ext_iff] - · rw [dif_neg h, if_neg h, Fin.ext_iff] + · 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 @@ -84,8 +84,8 @@ theorem dualSign_sq (ℓ : ℕ) (c : Fin (2 * ℓ)) : dualSign ℓ c * dualSign ℓ c = 1 := by unfold dualSign oddPartnerSign by_cases h : c.val < ℓ - · rw [if_pos h]; norm_num - · rw [if_neg h]; norm_num + · 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 * ℓ)) : @@ -101,13 +101,13 @@ theorem superLeg_f_g (ℓ : ℕ) (c : Fin (2 * ℓ)) : have hv := oddPartner_val ℓ c unfold dualSign symplecticJ oddPartnerSign by_cases h : c.val < ℓ - · rw [if_pos h] at hv - rw [if_pos hv, if_pos h] + · rw [ite_eq_left h] at hv + rw [ite_eq_left hv, ite_eq_left h] norm_num - · rw [if_neg h] at hv - rw [if_neg (show ¬ ((oddPartner ℓ c).val = c.val + ℓ) by omega), - if_pos (show c.val = (oddPartner ℓ c).val + ℓ by omega), - if_neg h] + · 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorAssoc.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorAssoc.lean index f893286020..9065003f6e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorAssoc.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorAssoc.lean @@ -65,11 +65,11 @@ theorem assocLabel_eq : 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 show a.val = s₁ + (a.val - s₁); omega), + Fin.ext (by change a.val = s₁ + (a.val - s₁); omega), interleaveEquiv_inl_high, interleaveEquiv_inl_high, interleaveEquiv_inl_high] exact Fin.ext (by - show ((s₁ + s₂) + s₃) + (a.val - s₁) = + change ((s₁ + s₂) + s₃) + (a.val - s₁) = (s₁ + (s₂ + s₃)) + (a.val - s₁) omega) · simp only [_root_.Equiv.sumAssoc_symm_apply_inr_inl, @@ -81,11 +81,11 @@ theorem assocLabel_eq : 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 show b.val = s₂ + (b.val - s₂); omega), + 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 - show ((s₁ + s₂) + s₃) + (t₁ + (b.val - s₂)) = + 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, @@ -95,15 +95,15 @@ theorem assocLabel_eq : interleaveEquiv_inr_low, interleaveEquiv_inr_low, interleaveEquiv_inr_low] exact Fin.ext (by - show (s₁ + s₂) + c.val = s₁ + (s₂ + c.val) + 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 show c.val = s₃ + (c.val - s₃); omega), + Fin.ext (by change c.val = s₃ + (c.val - s₃); omega), interleaveEquiv_inr_high, interleaveEquiv_inr_high, interleaveEquiv_inr_high] exact Fin.ext (by - show ((s₁ + s₂) + s₃) + ((t₁ + t₂) + (c.val - s₃)) = + change ((s₁ + s₂) + s₃) + ((t₁ + t₂) + (c.val - s₃)) = (s₁ + (s₂ + s₃)) + (t₁ + (t₂ + (c.val - s₃))) omega) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorComm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorComm.lean index 6ec36012c2..3ab53398ad 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorComm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorComm.lean @@ -96,7 +96,7 @@ theorem connectionMap_tensor_right_single rfl | add y z hy hz => rw [map_add, map_add] - show connectionMap f ((s + u) + (t + v)) _ K + + change connectionMap f ((s + u) + (t + v)) _ K + connectionMap f ((s + u) + (t + v)) _ K = _ rw [hy, hz, map_add] rfl diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorIdeal.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorIdeal.lean index 8148da64ef..2b7d94975b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorIdeal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorIdeal.lean @@ -91,7 +91,7 @@ theorem ipHigh_split (s t u v : ℕ) : (congrArg Sum.inr (Fin.ext ?_)) <;> rfl · refine Prod.ext (congrArg Sum.inl (Fin.ext ?_)) (congrArg Sum.inr (Fin.ext ?_)) <;> - · show (s + u) + (t + l.val) = (s + u) + (t + l.val) + · change (s + u) + (t + l.val) = (s + u) + (t + l.val) rfl /-- The low closure half splits at `s`. -/ @@ -155,7 +155,7 @@ private theorem tensor_ground_zv_aux (s t u v : ℕ) : simp only [List.map_cons, Fragment.mapPairs, Prod.map] refine congrArg₂ List.cons (Prod.ext ?_ ?_) (tensor_ground_zv_aux s t u v l) - · show Sum.inl ((interleaveEquiv s t u v).symm + · 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), @@ -164,7 +164,7 @@ private theorem tensor_ground_zv_aux (s t u v : ℕ) : Fin.natAdd (s + u) (Fin.natAdd t l') from Fin.ext rfl, interleaveEquiv_symm_high_right] exact congrArg Sum.inr (Fin.ext rfl) - · show Sum.inr (⟨(s + u) + (t + l'.val), + · change Sum.inr (⟨(s + u) + (t + l'.val), by have := l'.isLt; omega⟩ : Fin ((s + u) + (t + v))) = _ rfl @@ -187,7 +187,7 @@ private theorem tensor_ground_xt_aux (s t u v : ℕ) : simp only [List.map_cons, Fragment.mapPairs, Prod.map] refine congrArg₂ List.cons (Prod.ext ?_ ?_) (tensor_ground_xt_aux s t u v l) - · show Sum.inl ((interleaveEquiv s t u v).symm + · 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⟩ : @@ -195,7 +195,7 @@ private theorem tensor_ground_xt_aux (s t u v : ℕ) : Fin.natAdd (s + u) (Fin.castAdd v k) from Fin.ext rfl, interleaveEquiv_symm_high_left] exact congrArg Sum.inl (Fin.ext rfl) - · show Sum.inr (⟨(s + u) + k.val, by have := k.isLt; omega⟩ : + · change Sum.inr (⟨(s + u) + k.val, by have := k.isLt; omega⟩ : Fin ((s + u) + (t + v))) = _ rfl @@ -215,7 +215,7 @@ private theorem tensor_ground_zu_aux (s t u v : ℕ) : simp only [List.map_cons, Fragment.mapPairs, Prod.map] refine congrArg₂ List.cons (Prod.ext ?_ ?_) (tensor_ground_zu_aux s t u v l) - · show Sum.inl ((interleaveEquiv s t u v).symm + · 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⟩ : @@ -223,7 +223,7 @@ private theorem tensor_ground_zu_aux (s t u v : ℕ) : Fin.castAdd (t + v) (Fin.natAdd s j) from Fin.ext rfl, interleaveEquiv_symm_low_right] exact congrArg Sum.inr (Fin.ext rfl) - · show Sum.inr (⟨s + j.val, by have := j.isLt; omega⟩ : + · change Sum.inr (⟨s + j.val, by have := j.isLt; omega⟩ : Fin ((s + u) + (t + v))) = _ rfl @@ -243,7 +243,7 @@ private theorem tensor_ground_xs_aux (s t u v : ℕ) : simp only [List.map_cons, Fragment.mapPairs, Prod.map] refine congrArg₂ List.cons (Prod.ext ?_ ?_) (tensor_ground_xs_aux s t u v l) - · show Sum.inl ((interleaveEquiv s t u v).symm + · 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⟩ : @@ -251,7 +251,7 @@ private theorem tensor_ground_xs_aux (s t u v : ℕ) : Fin.castAdd (t + v) (Fin.castAdd u i) from Fin.ext rfl, interleaveEquiv_symm_low_left] exact congrArg Sum.inl (Fin.ext rfl) - · show Sum.inr (⟨i.val, by have := i.isLt; omega⟩ : + · change Sum.inr (⟨i.val, by have := i.isLt; omega⟩ : Fin ((s + u) + (t + v))) = _ rfl @@ -354,8 +354,8 @@ theorem xtSurv (s t u v : ℕ) (k : Fin t) : 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 show (s + u) ≤ (s + u) + k.val; omega, - by show (s + u) + k.val < (s + u) + t + (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. -/ @@ -478,11 +478,11 @@ theorem pcSurvEquiv_symm_high_val (s t u v : ℕ) (k : Fin 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 - show ((if hk : s + k.val < s then _ else _ : + change ((if hk : s + k.val < s then _ else _ : {x // pcSurvPred s t u v x})).val = _ - rw [dif_neg (show ¬ s + k.val < s by omega)] + rw [dite_eq_right (show ¬ s + k.val < s by omega)] exact congrArg Sum.inr (Fin.ext (by - show (s + u) + (s + k.val - s) = (s + u) + k.val + change (s + u) + (s + k.val - s) = (s + u) + k.val omega)) /-- The inverse survivor identification on low labels. -/ @@ -491,9 +491,9 @@ theorem pcSurvEquiv_symm_low_val (s t u v : ℕ) (i : Fin s) ((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 - show ((if hk : i.val < s then _ else _ : + change ((if hk : i.val < s then _ else _ : {x // pcSurvPred s t u v x})).val = _ - rw [dif_pos (show i.val < s from i.isLt)] + rw [dite_eq_left (show i.val < s from i.isLt)] /-! ### The right side's ground computation -/ @@ -513,7 +513,7 @@ private theorem rhs_ground_xt_aux (s t u v : ℕ) : 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) - show Sum.inr ((pcSurvEquiv s t u v).symm + 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] @@ -534,7 +534,7 @@ private theorem rhs_ground_xs_aux (s t u v : ℕ) : 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) - show Sum.inr ((pcSurvEquiv s t u v).symm + 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] @@ -764,6 +764,12 @@ noncomputable def absLabelL (s t u v : ℕ) : ((interfaceSurvEquiv 0 ((s + u) + (t + v)) 0).trans finSumFinEquiv)))))))))) +private theorem absPs0_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)`. -/ @@ -800,7 +806,7 @@ noncomputable def absNormalLeft {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) := - Fragment.mapPairs_wf iM.symm.symm _ wfLift + absPs0_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 @@ -986,7 +992,7 @@ theorem absSurv_empty (s t u v : ℕ) (List.mem_map.mpr ⟨⟨a.val - s, hk⟩, List.mem_reverse.mpr (List.mem_finRange _), rfl⟩)))).1 (congrArg Sum.inl (Fin.ext (by - show a.val = s + (a.val - s) + change a.val = s + (a.val - s) omega))) · obtain ⟨bv, hb⟩ := b have hpred : pcSurvPred s t u v bv := @@ -1006,7 +1012,7 @@ theorem absSurv_empty (s t u v : ℕ) List.mem_reverse.mpr (List.mem_finRange _), rfl⟩)))).2 (congrArg Sum.inr (Subtype.ext (congrArg Sum.inr (Fin.ext (by - show c.val = (s + u) + (c.val - (s + u)) + change c.val = (s + u) + (c.val - (s + u)) omega))))) /-- **The absorption** (accompanying paper, Lemma 3.3(b), geometric @@ -1075,7 +1081,7 @@ theorem connectionMap_tensor_single (f : ClosedFragment → ℂ) rfl | add y w hy hw => rw [map_add, LinearMap.add_apply, map_add] - show connectionMap f ((s + u) + (t + v)) _ K + + change connectionMap f ((s + u) + (t + v)) _ K + connectionMap f ((s + u) + (t + v)) _ K = _ rw [hy, hw, map_add] rfl diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean index 1694c11202..ecb56817dc 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean @@ -41,7 +41,7 @@ noncomputable def disjUnionExchange W₁.Vertex W₂.Vertex W₃.Vertex W₄.Vertex attach_comm := fun f => by rcases f with (f | f) | (f | f) - · show (((W₁.attach f).map Sum.inl Sum.inl).map + · 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 @@ -49,7 +49,7 @@ noncomputable def disjUnionExchange (_root_.Equiv.sumSumSumComm W₁.Vertex W₂.Vertex W₃.Vertex W₄.Vertex) id rcases W₁.attach f with v | ℓ <;> rfl - · show (((W₂.attach f).map Sum.inl Sum.inl).map + · 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 @@ -57,7 +57,7 @@ noncomputable def disjUnionExchange (_root_.Equiv.sumSumSumComm W₁.Vertex W₂.Vertex W₃.Vertex W₄.Vertex) id rcases W₂.attach f with v | ℓ <;> rfl - · show (((W₃.attach f).map Sum.inr Sum.inr).map + · 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 @@ -65,7 +65,7 @@ noncomputable def disjUnionExchange (_root_.Equiv.sumSumSumComm W₁.Vertex W₂.Vertex W₃.Vertex W₄.Vertex) id rcases W₃.attach f with v | ℓ <;> rfl - · show (((W₄.attach f).map Sum.inr Sum.inr).map + · 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 @@ -76,7 +76,7 @@ noncomputable def disjUnionExchange pairing_comm := fun f => by rcases f with (f | f) | (f | f) <;> rfl circles_eq := by - show W₁.circles + W₂.circles + + change W₁.circles + W₂.circles + (W₃.circles + W₄.circles) = W₁.circles + W₃.circles + (W₂.circles + W₄.circles) @@ -153,7 +153,7 @@ private theorem interchange_ground_low_aux Fragment.inlPairs, Prod.map] refine congrArg₂ List.cons (Prod.ext ?_ ?_) (interchange_ground_low_aux s₁ t₁ u₁ s₂ t₂ u₂ l) - · show (_root_.Equiv.sumSumSumComm + · change (_root_.Equiv.sumSumSumComm (Fin (s₁+t₁)) (Fin (s₂+t₂)) (Fin (t₁+u₁)) (Fin (t₂+u₂))) (Sum.inl ((interleaveEquiv s₁ t₁ s₂ t₂).symm @@ -167,7 +167,7 @@ private theorem interchange_ground_low_aux from Fin.ext rfl, interleaveEquiv_symm_high_left] simp [_root_.Equiv.sumSumSumComm, Fin.ext_iff] - · show (_root_.Equiv.sumSumSumComm + · change (_root_.Equiv.sumSumSumComm (Fin (s₁+t₁)) (Fin (s₂+t₂)) (Fin (t₁+u₁)) (Fin (t₂+u₂))) (Sum.inr ((interleaveEquiv t₁ u₁ t₂ u₂).symm @@ -215,7 +215,7 @@ private theorem interchange_ground_high_aux Fragment.inrPairs, Prod.map] refine congrArg₂ List.cons (Prod.ext ?_ ?_) (interchange_ground_high_aux s₁ t₁ u₁ s₂ t₂ u₂ l) - · show (_root_.Equiv.sumSumSumComm + · change (_root_.Equiv.sumSumSumComm (Fin (s₁+t₁)) (Fin (s₂+t₂)) (Fin (t₁+u₁)) (Fin (t₂+u₂))) (Sum.inl ((interleaveEquiv s₁ t₁ s₂ t₂).symm @@ -229,7 +229,7 @@ private theorem interchange_ground_high_aux from Fin.ext rfl, interleaveEquiv_symm_high_right] simp [_root_.Equiv.sumSumSumComm, Fin.ext_iff] - · show (_root_.Equiv.sumSumSumComm + · change (_root_.Equiv.sumSumSumComm (Fin (s₁+t₁)) (Fin (s₂+t₂)) (Fin (t₁+u₁)) (Fin (t₂+u₂))) (Sum.inr ((interleaveEquiv t₁ u₁ t₂ u₂).symm @@ -368,6 +368,230 @@ private theorem liftPairs_inlPairs_inrPairs /-! ### 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`. @@ -546,171 +770,8 @@ noncomputable def interchangeNormalRight (tensorFragment G₁ G₂)).trans ((Equiv.relabelCongr C_total surv_c).trans ((Equiv.relabelTrans _ _ _).trans - (Equiv.relabelEq _ (by - apply _root_.Equiv.ext; intro x - have h_sc : surv_c = - (interfaceSurvEquiv (s₁+s₂) (t₁+t₂) - (u₁+u₂)).trans finSumFinEquiv := rfl - cases x with - | inl fs₁ => - 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 - show (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 [h_sc, _root_.Equiv.trans_apply] - refine (congrArg finSumFinEquiv - (interfaceSurvEquiv_inl (s₁+s₂) (t₁+t₂) (u₁+u₂) - _ (ieF (Sum.inl a)) - (by - show 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 - show (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 - show 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 [h_sc, _root_.Equiv.trans_apply] - refine (congrArg finSumFinEquiv - (interfaceSurvEquiv_inr (s₁+s₂) (t₁+t₂) (u₁+u₂) - _ (ieG (Sum.inl b)) - (by - show 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 - show (ieG (Sum.inl b)).val - (t₁ + t₂) = - b.val - t₁ - rw [hie_val] - omega)) - | inr fs₂ => - 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 - show (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 [h_sc, _root_.Equiv.trans_apply] - refine (congrArg finSumFinEquiv - (interfaceSurvEquiv_inl (s₁+s₂) (t₁+t₂) (u₁+u₂) - _ (ieF (Sum.inr c)) - (by - show 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 - show (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 - show 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 [h_sc, _root_.Equiv.trans_apply] - refine (congrArg finSumFinEquiv - (interfaceSurvEquiv_inr (s₁+s₂) (t₁+t₂) (u₁+u₂) - _ (ieG (Sum.inr d)) - (by - show 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 - show (ieG (Sum.inr d)).val - (t₁ + t₂) = - u₁ + (d.val - t₂) - rw [hie_val] - omega)))))) + (Equiv.relabelEq _ (interchange_survivor_relabel_eq _ + (fun x => by cases x <;> rfl))))) /-! ### Final assembly -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorUnit.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorUnit.lean index 78425cad40..a642808599 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorUnit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorUnit.lean @@ -23,13 +23,13 @@ theorem interleave_unit_left (s t : ℕ) (ℓ : Fin (s + t)) : by_cases hl : ℓ.val < s · rw [show ℓ = Fin.castAdd t ⟨ℓ.val, hl⟩ from Fin.ext rfl, interleaveEquiv_inr_low] - exact Fin.ext (by show 0 + ℓ.val = ℓ.val; omega) + 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 show ℓ.val = s + (ℓ.val - s); omega), + Fin.ext (by change ℓ.val = s + (ℓ.val - s); omega), interleaveEquiv_inr_high] exact Fin.ext (by - show (0 + s) + (0 + (ℓ.val - s)) = s + (ℓ.val - s) + change (0 + s) + (0 + (ℓ.val - s)) = s + (ℓ.val - s) omega) /-- The interleave against an empty right factor is the cast. -/ @@ -42,10 +42,10 @@ theorem interleave_unit_right (s t : ℕ) (ℓ : Fin (s + t)) : 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 show ℓ.val = s + (ℓ.val - s); omega), + Fin.ext (by change ℓ.val = s + (ℓ.val - s); omega), interleaveEquiv_inl_high] exact Fin.ext (by - show (s + 0) + (ℓ.val - s) = s + (ℓ.val - s) + change (s + 0) + (ℓ.val - s) = s + (ℓ.val - s) omega) /-- **The left unit**: the empty fragment tensors away. -/ @@ -63,7 +63,7 @@ noncomputable def tensorFragmentUnitLeft {s t : ℕ} attach_comm := fun f => by rcases f with f | f · exact f.elim - · show (X.attach f).map id + · 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 @@ -77,7 +77,7 @@ noncomputable def tensorFragmentUnitLeft {s t : ℕ} · exact f.elim · rfl circles_eq := by - show 0 + X.circles = X.circles + change 0 + X.circles = X.circles omega /-- **The right unit**: the empty fragment tensors away. -/ @@ -94,7 +94,7 @@ noncomputable def tensorFragmentUnitRight {s t : ℕ} _root_.Equiv.sumEmpty X.Vertex Empty attach_comm := fun f => by rcases f with f | f - · show (X.attach f).map id + · 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 @@ -109,7 +109,7 @@ noncomputable def tensorFragmentUnitRight {s t : ℕ} · rfl · exact f.elim circles_eq := by - show X.circles + 0 = X.circles + 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 index 43173b565c..32b46520e9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughEdgeCut.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughEdgeCut.lean @@ -21,7 +21,7 @@ cut. namespace RS -open scoped Classical + namespace EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughIndCFalse.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughIndCFalse.lean index 7ff305c936..4c3176cac8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughIndCFalse.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughIndCFalse.lean @@ -24,7 +24,7 @@ the pairing-resolved value. namespace RS -open scoped Classical + namespace TransposeVerify diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceCyclic.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceCyclic.lean index d8425330d3..458a4848df 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceCyclic.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceCyclic.lean @@ -40,7 +40,7 @@ theorem transposeEquiv_symm (n p : ℕ) : · 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 show x.val = p + (x.val - p); omega), + (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 @@ -64,9 +64,9 @@ theorem cast_trans_outPerm {t : ℕ} (e : Equiv.Perm (Fin t)) : 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 show j.val = 0 + j.val; omega), + Fin.natAdd 0 j from Fin.ext (by change j.val = 0 + j.val; omega), outPermEquiv_high 0 e j] - exact Fin.ext (by show (e j).val = 0 + (e j).val; omega) + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceNondegenerate.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceNondegenerate.lean index 84cafaccc3..40c5b92f9d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceNondegenerate.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceNondegenerate.lean @@ -52,7 +52,7 @@ theorem connectionMap_eq_trace_row (f : ClosedFragment → ℂ) rfl | add y z hy hz => rw [map_add] - show connectionMap f (t + u) y H + + 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 => diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean index 19ef09bf30..4ec69b0dce 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean @@ -35,10 +35,11 @@ open Classical in 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} [DecidableEq β] +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 @@ -59,7 +60,7 @@ theorem exists_involution_of_even {β : Type} [DecidableEq β] 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 - show ((s.erase a).erase b).card = (s.erase a).card - 1 + 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 @@ -81,9 +82,9 @@ theorem exists_involution_of_even {β : Type} [DecidableEq β] · rw [h2, hm_b]; exact ha · rw [hm_other x h1 h2] have hxs' : x ∈ s' := by - simp [hs'_def, Finset.mem_erase]; exact ⟨h2, h1, hx⟩ + simp? [hs'_def, Finset.mem_erase]; exact ⟨h2, h1, hx⟩ have := hm'_mem x hxs' - simp [hs'_def, Finset.mem_erase] at this; exact this.2.2 + simp? [hs'_def, Finset.mem_erase] at this; exact this.2.2 · -- m is an involution on s intro x hx by_cases h1 : x = a @@ -92,7 +93,7 @@ theorem exists_involution_of_even {β : Type} [DecidableEq β] · rw [h2, hm_b, hm_a] · rw [hm_other x h1 h2] have hxs' : x ∈ s' := by - simp [hs'_def, Finset.mem_erase]; exact ⟨h2, h1, hx⟩ + simp? [hs'_def, Finset.mem_erase]; 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] @@ -105,7 +106,7 @@ theorem exists_involution_of_even {β : Type} [DecidableEq β] · rw [h2, hm_b] at hfp; exact hab hfp · rw [hm_other x h1 h2] at hfp have hxs' : x ∈ s' := by - simp [hs'_def, Finset.mem_erase]; exact ⟨h2, h1, hx⟩ + simp? [hs'_def, Finset.mem_erase]; exact ⟨h2, h1, hx⟩ exact hm'_ne x hxs' hfp /-! ### Part 1: constructing the transition system -/ @@ -141,7 +142,7 @@ noncomputable def EdgeSubset.buildTransitionSystem {α : Type} 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 := dif_pos hf + 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] @@ -282,7 +283,7 @@ theorem conj_zpow (κ : F.TransitionSystem) (n : ℤ) : map_zpow (MulAut.conj F.pairingPerm).toMonoidHom κ.walkPerm n _ = κ.walkPerm⁻¹ ^ n := by congr 1 - show F.pairingPerm * κ.walkPerm * F.pairingPerm⁻¹ = κ.walkPerm⁻¹ + change F.pairingPerm * κ.walkPerm * F.pairingPerm⁻¹ = κ.walkPerm⁻¹ rw [hσ_inv]; exact κ.conj_eq_inv _ = κ.walkPerm ^ (-n) := inv_zpow' κ.walkPerm n @@ -459,13 +460,13 @@ noncomputable def EdgeSubset.TransitionSystem.buildOrientation -- match_flip have hmatch_flip : ∀ g ∈ F.flags, isOut (κ.match_ g) = !isOut g := by intro g hg - simp only [isOut, dif_pos hg, dif_pos (κ.match_mem 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 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, dif_pos hg, dif_pos (F.pairing_mem 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]) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionMove.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionMove.lean index e896f59977..dbf7e0437e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionMove.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionMove.lean @@ -62,7 +62,7 @@ segment. namespace RS -open scoped Classical + variable {α : Type} @@ -615,7 +615,7 @@ def Orientation.transportRepair {κ : F.RelTransitionSystem} have hd' : o.isOut d = !o.isOut c := by rw [← h.hcd]; exact o.match_flip c h.hc intro f hf - show o.isOut (repairFun κ.match_ a b c d f) = !o.isOut f + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransposeLedger.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransposeLedger.lean index 211c2a19ea..6691fabde9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransposeLedger.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransposeLedger.lean @@ -72,7 +72,7 @@ theorem twoPathTransformFactor_eq_neg_one : section Transform -open scoped Classical + variable {α : Type} @@ -536,7 +536,7 @@ theorem cThroughSummand (κ : cSubset.RelTransitionSystem) unfold EdgeSubset.throughSummand rw [cThroughProduct, pow_zero, one_mul, one_mul] rw [Fintype.sum_subsingleton _ cPsi] - rw [if_pos cEvenMatch] + rw [ite_eq_left cEvenMatch] have hzero : ∀ φ : cSubset.CoreOddColouring 4, φ ≠ cPhi → (if cSubset.coreOddBoundaryMatch cState φ then ∏ v : cFragment.Vertex, @@ -549,9 +549,9 @@ theorem cThroughSummand (κ : cSubset.RelTransitionSystem) rcases Classical.em (cSubset.coreOddBoundaryMatch cState φ) with hb | hb · exact absurd (cPhi_unique φ hb) hφ - · rw [if_neg hb] + · rw [ite_eq_right hb] rw [Fintype.sum_eq_single cPhi hzero] - rw [if_pos cOddMatch] + rw [ite_eq_left cOddMatch] rw [Fintype.prod_subsingleton _ cV] rw [cCoreOddSignAt κ o g₁ g₂ hglist, cCoreOddListAt κ o g₁ g₂ hglist] @@ -781,12 +781,12 @@ theorem cSummand_O : oddPartner 4 (cColour 2)] = ([0, 5, 2, 7] : List (Fin (2 * 4))) from by decide, MixedFunctional.evalOdd, - if_pos (by decide : ([0, 5, 2, 7] : List (Fin (2 * 4))).Nodup), + 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, if_pos rfl] + cFunctional_apply, ite_eq_left rfl] norm_num · rw [cThroughSummand cKappa cO 3 0 h, show cKappa.match_ 0 = 1 from rfl, @@ -797,12 +797,12 @@ theorem cSummand_O : oddPartner 4 (cColour 1)] = ([2, 7, 0, 5] : List (Fin (2 * 4))) from by decide, MixedFunctional.evalOdd, - if_pos (by decide : ([2, 7, 0, 5] : List (Fin (2 * 4))).Nodup), + 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, if_pos rfl] + cFunctional_apply, ite_eq_left rfl] norm_num end TransposeVerify diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathNonSep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathNonSep.lean index b8ad27a597..203abe6baa 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathNonSep.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathNonSep.lean @@ -28,7 +28,7 @@ signs. namespace RS -open scoped Classical + /-! ## The two-label `∂`-relabel of a boundary state -/ @@ -48,17 +48,17 @@ variable {k ℓ : ℕ} {α : Type} {st : GenBoundaryState k ℓ α} /-- 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 := - if_neg (fun h => h.elim h1 h2) + ite_eq_right (fun h => h.elim h1 h2) /-- At the first label the state entry is `∂`-flipped. -/ theorem stateOddFlip_left : stateOddFlip st i₁ i₂ i₁ = Sum.map id (oddPartner ℓ) (st i₁) := - if_pos (Or.inl rfl) + ite_eq_left (Or.inl rfl) /-- At the second label likewise. -/ theorem stateOddFlip_right : stateOddFlip st i₁ i₂ i₂ = Sum.map id (oddPartner ℓ) (st i₂) := - if_pos (Or.inr rfl) + ite_eq_left (Or.inr rfl) /-- At the first label, on an odd entry: the colour is replaced by its odd partner. -/ @@ -81,7 +81,7 @@ theorem stateOddFlip_isInr (i : α) : ∃ c, st i = Sum.inr c := by unfold stateOddFlip by_cases h : i = i₁ ∨ i = i₂ - · rw [if_pos h] + · rw [ite_eq_left h] cases hst : st i with | inl a => constructor @@ -91,14 +91,14 @@ theorem stateOddFlip_isInr (i : α) : cases hc | inr b => exact ⟨fun _ => ⟨b, rfl⟩, fun _ => ⟨oddPartner ℓ b, rfl⟩⟩ - · rw [if_neg h] + · rw [ite_eq_right h] /-- 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 [if_pos h] + · rw [ite_eq_left h] cases hst : st i with | inl a' => exact Iff.rfl | inr b => @@ -107,7 +107,7 @@ theorem stateOddFlip_isInl (i : α) (a : Fin k) : cases hc · intro hc cases hc - · rw [if_neg h] + · rw [ite_eq_right h] /-- The boundary-membership constraint transfers across the relabel. -/ @@ -121,18 +121,18 @@ theorem genBoundarySubsetMatches_stateOddFlip {W : Fragment α} theorem stateOddFlip_stateOddFlip : stateOddFlip (stateOddFlip st i₁ i₂) i₁ i₂ = st := by funext i - show (if i = i₁ ∨ i = i₂ then + 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 [if_pos h, show stateOddFlip st i₁ i₂ i = - Sum.map id (oddPartner ℓ) (st i) from if_pos h] + · 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 => - show Sum.inr (oddPartner ℓ (oddPartner ℓ b)) = Sum.inr b + change Sum.inr (oddPartner ℓ (oddPartner ℓ b)) = Sum.inr b rw [oddPartner_invol] - · rw [if_neg h] + · rw [ite_eq_right h] exact stateOddFlip_of_ne (fun he => h (Or.inl he)) (fun he => h (Or.inr he)) @@ -292,9 +292,9 @@ noncomputable def RelTransitionSystem.Orientation.portFlip else o.isOut (κ.match_ f)) = !(if f ∈ S then !o.isOut f else o.isOut f) by_cases hfS : f ∈ S - · rw [if_pos (h.match_mem f hfS), if_pos hfS, + · rw [ite_eq_left (h.match_mem f hfS), ite_eq_left hfS, o.match_flip f hf] - · rw [if_neg (h.match_notMem hf hfS), if_neg hfS] + · 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 @@ -316,11 +316,11 @@ noncomputable def RelTransitionSystem.Orientation.portFlip obtain ⟨v, hv⟩ := F.attach_internal_of_mem hp rw [W.attach_boundaryFlag] at hv cases hv - rw [if_pos (h.pairing_mem f hfS hfp₁ hfp₂), if_pos hfS, + rw [ite_eq_left (h.pairing_mem f hfS hfp₁ hfp₂), ite_eq_left hfS, o.pairing_flip f hf hp] - · rw [if_neg (h.pairing_notMem hfS + · rw [ite_eq_right (h.pairing_notMem hfS (PortedFlipSet.int_ne_boundaryFlag hf i₁) - (PortedFlipSet.int_ne_boundaryFlag hf i₂)), if_neg hfS] + (PortedFlipSet.int_ne_boundaryFlag hf i₂)), ite_eq_right hfS] exact o.pairing_flip f hf hp section PortFlipEval @@ -329,11 +329,11 @@ 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 := if_pos hf + (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 := if_neg hf + (o.portFlip h).isOut f = o.isOut f := ite_eq_right hf end PortFlipEval @@ -439,7 +439,7 @@ 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, if_pos (mem_portFlipCore_of_mem hg)] + 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. -/ @@ -449,7 +449,7 @@ theorem portColourFlip_val_int_of_notMem (h : PortedFlipSet κ S p₁ p₂ i₁ (hgint : g.val ∈ F.internalFlags) (hg : g.val ∉ S) : (portColourFlip h φ).val g = φ.val g := by rw [portColourFlip_val h φ g, - if_neg (fun hc => hg ((h.mem_flipCore_int hgint).mp hc))] + 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 @@ -460,7 +460,7 @@ theorem portColourFlip_val_bF₁ (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) (portColourFlip h φ).val ⟨W.boundaryFlag i₁, hcore⟩ = oddPartner ℓ (φ.val ⟨W.boundaryFlag i₁, hcore⟩) := by rw [portColourFlip_val h φ _, - if_pos ((h.mem_flipCore_boundaryFlag i₁).mpr (Or.inl rfl))] + 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₂) @@ -469,7 +469,7 @@ theorem portColourFlip_val_bF₂ (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) (portColourFlip h φ).val ⟨W.boundaryFlag i₂, hcore⟩ = oddPartner ℓ (φ.val ⟨W.boundaryFlag i₂, hcore⟩) := by rw [portColourFlip_val h φ _, - if_pos ((h.mem_flipCore_boundaryFlag i₂).mpr (Or.inr rfl))] + 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. -/ @@ -478,7 +478,7 @@ theorem portColourFlip_val_bF_of_ne (h : PortedFlipSet κ S p₁ p₂ 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 φ _, if_neg (fun hc => 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)] @@ -557,7 +557,7 @@ private theorem inSign_portFlip_of_mem have hcore : g ∈ F.coreFlags := F.internalFlags_subset_coreFlags (h.int_of_mem g hg) unfold inSign - rw [dif_pos hcore, dif_pos hcore, + rw [dite_eq_left hcore, dite_eq_left hcore, portColourFlip_val_of_mem h φ ⟨g, hcore⟩ hg, oddPartnerSign_oddPartner] @@ -568,7 +568,7 @@ private theorem inSign_portFlip_of_int_notMem have hcore : g ∈ F.coreFlags := F.internalFlags_subset_coreFlags hgint unfold inSign - rw [dif_pos hcore, dif_pos hcore, + rw [dite_eq_left hcore, dite_eq_left hcore, portColourFlip_val_int_of_notMem h φ ⟨g, hcore⟩ hgint hg] /-! ### Vertex-local in-sets -/ @@ -943,7 +943,7 @@ private theorem evalList_portFlip have hgS : g ∉ S := (mem_keepP.mp (Finset.mem_toList.mp hg)).2 have hmS : κ.match_ g ∉ S := h.match_notMem h₁ hgS - show [(portColourFlip h φ).val + change [(portColourFlip h φ).val ⟨g, F.internalFlags_subset_coreFlags h₁⟩, oddPartner ℓ ((portColourFlip h φ).val ⟨κ.match_ g, F.internalFlags_subset_coreFlags @@ -967,7 +967,7 @@ private theorem evalList_portFlip {g : W.Flag // g ∈ F.coreFlags}) = ⟨f, F.internalFlags_subset_coreFlags h₂⟩ := Subtype.ext (κ.match_invol f h₂) - show [(portColourFlip h φ).val + change [(portColourFlip h φ).val ⟨κ.match_ f, F.internalFlags_subset_coreFlags h₁⟩, oddPartner ℓ ((portColourFlip h φ).val ⟨κ.match_ (κ.match_ f), @@ -1095,7 +1095,7 @@ private theorem inSign_pin₁ (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) φ.val ⟨W.boundaryFlag i₁, h.bF₁_core⟩ := φ.prop ⟨W.boundaryFlag i₁, h.bF₁_core⟩ have h3 : inSign φ p₁ = - oddPartnerSign ℓ (φ.val ⟨p₁, h.p₁_core⟩) := dif_pos h.p₁_core + 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₂) @@ -1117,7 +1117,7 @@ private theorem inSign_pin₂ (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) φ.val ⟨W.boundaryFlag i₂, h.bF₂_core⟩ := φ.prop ⟨W.boundaryFlag i₂, h.bF₂_core⟩ have h3 : inSign φ p₂ = - oddPartnerSign ℓ (φ.val ⟨p₂, h.p₂_core⟩) := dif_pos h.p₂_core + oddPartnerSign ℓ (φ.val ⟨p₂, h.p₂_core⟩) := dite_eq_left h.p₂_core rw [h3, h1, h2, hval] /-! ### The colouring-sum and even-sum identities -/ @@ -1145,7 +1145,7 @@ private theorem phiSum_portFlip (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) refine ((Equiv.sum_comp (Function.Involutive.toPerm _ (portColourFlip_involutive h)) _).symm).trans (Finset.sum_congr rfl (fun φ _ => ?_)) - show (if F.coreOddBoundaryMatch st (portColourFlip h φ) then + change (if F.coreOddBoundaryMatch st (portColourFlip h φ) then ∏ vv : W.Vertex, ((F.coreOddSignAt (o.portFlip h) (portColourFlip h φ) vv : ℂ) * @@ -1162,16 +1162,16 @@ private theorem phiSum_portFlip (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) rcases Classical.em (F.coreOddBoundaryMatch (stateOddFlip st i₁ i₂) φ) with hO | hO - · rw [if_pos ((coreOddBoundaryMatch_portColourFlip h st φ).mpr + · rw [ite_eq_left ((coreOddBoundaryMatch_portColourFlip h st φ).mpr hO), - if_pos hO, vertexProd_portFlip h hM o φ μf, + 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 [if_neg (fun hc => + · rw [ite_eq_right (fun hc => hO ((coreOddBoundaryMatch_portColourFlip h st φ).mp hc)), - if_neg hO, mul_zero] + ite_eq_right hO, mul_zero] private theorem evenMatch_stateOddFlip {st : GenBoundaryState k ℓ α} (hbnd : genBoundarySubsetMatches W F.flags st) @@ -1258,7 +1258,7 @@ private theorem tBody_stateOddFlip [LinearOrder α] cases hi unfold tBody rw [hi, hj] - show (if i < j then + 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) @@ -1316,10 +1316,10 @@ theorem psiSum_portFlip refine Finset.sum_congr rfl (fun ψ _ => ?_) rcases Classical.em (genEvenBoundaryMatch F st hbnd ψ) with hE | hE - · rw [if_pos hE, if_pos ((evenMatch_stateOddFlip hbnd ψ).mpr 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 [if_neg hE, - if_neg (fun hc => hE ((evenMatch_stateOddFlip hbnd ψ).mp hc)), + · 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathStep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathStep.lean index 12ae14d598..b513014823 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathStep.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathStep.lean @@ -32,7 +32,7 @@ in `TransposeLedger.lean`, on top of this count invariance. namespace RS -open scoped Classical + namespace EdgeSubset @@ -68,7 +68,7 @@ theorem not_periodic_of_onBoundaryChain {β f : W.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 [LinearOrder α] {β β' f : W.Flag} +theorem onBoundaryChain_disjoint {β β' f : W.Flag} (hβ : β ∈ F.boundaryFlags) (hβ' : β' ∈ F.boundaryFlags) (hne : β' ≠ β) (hne' : β' ≠ κ.pathMatch β hβ) (h : OnBoundaryChain κ β f) (h' : OnBoundaryChain κ β' f) : @@ -446,7 +446,7 @@ theorem openCircuitCount_repair_of_not_localized [LinearOrder α] rw [Equiv.permCongr_apply] simp only [Equiv.subtypeEquivRight_symm_apply, Equiv.subtypeEquivRight_apply] - show (κ.repair a b c d v hsq).match_ (W.pairing f) = + 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σ)) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexOddSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexOddSign.lean index b815f12071..46ccda967a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexOddSign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexOddSign.lean @@ -23,13 +23,14 @@ analysis a product of independent local factors. namespace RS -open scoped Classical + 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} @@ -42,8 +43,9 @@ 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 := - Finset.mem_filter + 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} @@ -57,8 +59,8 @@ theorem relInFlagsAt_coe {κ₀ : F.RelTransitionSystem} (o₀ : κ₀.Orientation) (vv : W.Vertex) : (F.relInFlagsAt o₀ vv : Multiset W.Flag) = (relInSetAt o₀ vv).val := by - letI := W.flagOrder - letI := Classical.dec + let := W.flagOrder + let := Classical.dec unfold EdgeSubset.relInFlagsAt rw [Finset.sort_eq] exact congrArg Finset.val (Finset.ext (fun g => by @@ -132,7 +134,7 @@ theorem inSign_flip_of_mem {φ φ' : F.CoreOddColouring ℓ} {g : W.Flag} (hg : g ∈ S) (hcore : g ∈ F.coreFlags) : inSign φ' g = -inSign φ g := by unfold inSign - rw [dif_pos hcore, dif_pos hcore, hφ' ⟨g, hcore⟩, if_pos hg, + 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. -/ @@ -142,18 +144,18 @@ theorem inSign_flip_of_notMem {φ φ' : F.CoreOddColouring ℓ} {g : W.Flag} (hg : g ∉ S) : inSign φ' g = inSign φ g := by unfold inSign by_cases hcore : g ∈ F.coreFlags - · rw [dif_pos hcore, dif_pos hcore, hφ' ⟨g, hcore⟩, if_neg hg] - · rw [dif_neg hcore, dif_neg hcore] + · 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 [dif_pos hg] + · rw [dite_eq_left hg] unfold oddPartnerSign by_cases h : (φ.val ⟨g, hg⟩).val < ℓ <;> simp [h] - · rw [dif_neg hg] + · rw [dite_eq_right hg] norm_num /-- Paired flags carry the same sign. -/ @@ -161,7 +163,7 @@ theorem inSign_pairing (φ : F.CoreOddColouring ℓ) {g : W.Flag} (hg : g ∈ F.coreFlags) : inSign φ (W.pairing g) = inSign φ g := by unfold inSign - rw [dif_pos (F.pairing_mem_coreFlags hg), dif_pos hg] + 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 -/ @@ -180,7 +182,7 @@ theorem signFn_eq {κ₀ : F.RelTransitionSystem} (f : {f : W.Flag // f ∈ F.internalFlags}) : F.coreOddSignFn κ₀ φ f = inSign φ (κ₀.match_ f.val) := by unfold EdgeSubset.coreOddSignFn inSign - rw [dif_pos + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexSum.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexSum.lean index 26fbc51e47..2d3df125f6 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexSum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexSum.lean @@ -26,10 +26,11 @@ namespace RS namespace EdgeSubset -open Classical + 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 α} diff --git a/LeanPool/RegtsSevenster/RS/StatementConverse.lean b/LeanPool/RegtsSevenster/RS/StatementConverse.lean index 4d28bda34c..17e97886eb 100644 --- a/LeanPool/RegtsSevenster/RS/StatementConverse.lean +++ b/LeanPool/RegtsSevenster/RS/StatementConverse.lean @@ -60,8 +60,8 @@ theorem mixedPartition_of_flagless [IsEmpty W.Flag] [IsEmpty W.Vertex] unfold mixedPartition rw [Fintype.sum_eq_single ∅ (fun s hs => absurd (Finset.eq_empty_of_isEmpty s) hs)] - rw [dif_pos (fun f hf => absurd hf (Finset.notMem_empty f))] - rw [if_pos (show (EdgeSubset.mk (∅ : Finset W.Flag) + 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) @@ -74,28 +74,28 @@ theorem mixedPartition_of_flagless [IsEmpty W.Flag] [IsEmpty W.Vertex] rw [show (EdgeSubset.mk (∅ : Finset W.Flag) (fun f hf => absurd hf (Finset.notMem_empty f))) = flaglessEmptySubset W from rfl] - rw [EdgeSubset.mixedValue, dif_pos hne] + rw [EdgeSubset.mixedValue, dite_eq_left hne] unfold EdgeSubset.mixedSummand have hcirc : ∀ κ : (flaglessEmptySubset W).TransitionSystem, κ.circuitCount = 0 := by intro κ unfold EdgeSubset.TransitionSystem.circuitCount - haveI : IsEmpty {f : W.Flag // + 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] - haveI : IsEmpty {f : W.Flag // + have : IsEmpty {f : W.Flag // f ∉ (flaglessEmptySubset W).flags} := ⟨fun f => isEmptyElim f.val⟩ - haveI : IsEmpty {f : W.Flag // + have : IsEmpty {f : W.Flag // f ∈ (flaglessEmptySubset W).flags} := ⟨fun f => isEmptyElim f.val⟩ - haveI : Subsingleton + have : Subsingleton ((flaglessEmptySubset W).EvenColouring k) := ⟨fun a b => Subtype.ext (funext fun f => isEmptyElim f)⟩ - haveI : Subsingleton + have : Subsingleton ((flaglessEmptySubset W).OddColouring ℓ) := ⟨fun a b => Subtype.ext (funext fun f => isEmptyElim f)⟩ rw [Fintype.sum_subsingleton _ @@ -112,9 +112,9 @@ end EmptyValue the empty closed fragment is `1`. -/ theorem mixedPartition_empty {k ℓ : ℕ} (h : MixedFunctional k ℓ) : mixedPartition h emptyClosedFragment = 1 := by - haveI : IsEmpty emptyClosedFragment.Flag := + have : IsEmpty emptyClosedFragment.Flag := inferInstanceAs (IsEmpty Empty) - haveI : IsEmpty emptyClosedFragment.Vertex := + have : IsEmpty emptyClosedFragment.Vertex := inferInstanceAs (IsEmpty Empty) rw [mixedPartition_of_flagless emptyClosedFragment h] rw [show emptyClosedFragment.circles = 0 from rfl] diff --git a/LeanPool/RegtsSevenster/RS/TheoremConverse.lean b/LeanPool/RegtsSevenster/RS/TheoremConverse.lean index a36df9d73f..c77573ba7e 100644 --- a/LeanPool/RegtsSevenster/RS/TheoremConverse.lean +++ b/LeanPool/RegtsSevenster/RS/TheoremConverse.lean @@ -18,7 +18,7 @@ quantitative round trip rest on Deligne alone. namespace RS -open Classical + /-- The converse rank bound with the exact total dimension as its base, including the zero-dimensional model. -/ diff --git a/LeanPool/RegtsSevenster/RS/TheoremPadding.lean b/LeanPool/RegtsSevenster/RS/TheoremPadding.lean index 550e2dbf7d..d10e59113b 100644 --- a/LeanPool/RegtsSevenster/RS/TheoremPadding.lean +++ b/LeanPool/RegtsSevenster/RS/TheoremPadding.lean @@ -23,8 +23,8 @@ power of the superdimension. -/ theorem mixedPartition_circlesClosed {k ℓ : ℕ} (h : MixedFunctional k ℓ) (c : ℕ) : mixedPartition h (circlesClosed c) = ((k : ℂ) - 2 * ℓ) ^ c := by - letI : IsEmpty (circlesClosed c).Flag := inferInstanceAs (IsEmpty Empty) - letI : IsEmpty (circlesClosed c).Vertex := inferInstanceAs (IsEmpty Empty) + 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 From a8ae7386fffa04e3b1b171d4699882aa2cf26342 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Fri, 25 Sep 2026 08:23:07 +0000 Subject: [PATCH 26/46] Migrate the complete Regts import to Lean modules --- LeanPool/RegtsSevenster.lean | 1676 +++++++++-------- LeanPool/RegtsSevenster/RS.lean | 46 +- .../RegtsSevenster/RS/Assembly/Blueprint.lean | 480 ++--- .../RS/Assembly/BlueprintConverse.lean | 8 +- .../RS/Assembly/BlueprintDeligne.lean | 6 +- .../RS/Assembly/BlueprintFactorial.lean | 12 +- .../RS/Assembly/BlueprintSchur.lean | 8 +- .../RS/Assembly/BlueprintStatement.lean | 14 +- LeanPool/RegtsSevenster/RS/Classical.lean | 276 +-- .../RS/Classical/Algebra/FactorialTrace.lean | 10 +- .../RS/Classical/Algebra/TraceCriterion.lean | 6 +- .../RS/Classical/CatTheory/Growth.lean | 6 +- .../RS/Classical/CatTheory/Intertwine.lean | 6 +- .../RS/Classical/CatTheory/KaroubiLinear.lean | 6 +- .../RS/Classical/CatTheory/KaroubiTrace.lean | 10 +- .../RS/Classical/CatTheory/Length.lean | 6 +- .../RS/Classical/CatTheory/LengthBound.lean | 8 +- .../Classical/CatTheory/LinearCategory.lean | 6 +- .../RS/Classical/CatTheory/PartialTrace.lean | 6 +- .../RS/Classical/CatTheory/TensorPow.lean | 6 +- .../RS/Classical/CatTheory/Trace.lean | 6 +- .../RS/Classical/CatTheory/UnitEnd.lean | 6 +- .../Classical/CatTheory/WhiskerAdditive.lean | 6 +- .../RegtsSevenster/RS/Classical/Deligne.lean | 656 +++---- .../RS/Classical/Deligne/AltPow.lean | 6 +- .../RS/Classical/Deligne/AltPowAct.lean | 8 +- .../Classical/Deligne/BaseChangeAdjoint.lean | 8 +- .../Classical/Deligne/BaseChangeBiprod.lean | 6 +- .../Deligne/BaseChangeCoherence.lean | 8 +- .../RS/Classical/Deligne/BaseChangeDatum.lean | 8 +- .../RS/Classical/Deligne/BaseChangeFree.lean | 6 +- .../Classical/Deligne/BaseChangeLinear.lean | 8 +- .../Classical/Deligne/BaseChangeMonoidal.lean | 8 +- .../Classical/Deligne/BaseChangeTensor.lean | 8 +- .../Deligne/BaseChangeTransport.lean | 10 +- .../Classical/Deligne/BaseChangeZigzag.lean | 6 +- .../RS/Classical/Deligne/BigTensor.lean | 6 +- .../RS/Classical/Deligne/BigTensorUnit.lean | 6 +- .../RS/Classical/Deligne/BiprodPow.lean | 8 +- .../RS/Classical/Deligne/BiprodTransfer.lean | 10 +- .../RS/Classical/Deligne/BlockUnits.lean | 8 +- .../RS/Classical/Deligne/BraidCoherence.lean | 6 +- .../RS/Classical/Deligne/ChainAlgebra.lean | 6 +- .../RS/Classical/Deligne/ChainB.lean | 10 +- .../RS/Classical/Deligne/ChainBGr.lean | 6 +- .../RS/Classical/Deligne/ChainBGraded.lean | 12 +- .../Classical/Deligne/ChainBGradedLaws.lean | 6 +- .../RS/Classical/Deligne/ChainBInd.lean | 8 +- .../RS/Classical/Deligne/ChainBNonzero.lean | 8 +- .../RS/Classical/Deligne/ChainBofA.lean | 10 +- .../RS/Classical/Deligne/ChainBridge.lean | 6 +- .../RS/Classical/Deligne/ChainDelta.lean | 8 +- .../RS/Classical/Deligne/ChainIns.lean | 4 +- .../RS/Classical/Deligne/ChainIns/Base.lean | 6 +- .../Classical/Deligne/ChainIns/FirstSlot.lean | 6 +- .../Deligne/ChainIns/SecondSlot.lean | 6 +- .../RS/Classical/Deligne/ChainMul.lean | 6 +- .../RS/Classical/Deligne/ChainMulHet.lean | 6 +- .../RS/Classical/Deligne/ChainMulLaws.lean | 8 +- .../RS/Classical/Deligne/ChainNonzero.lean | 8 +- .../RS/Classical/Deligne/ChainShift.lean | 6 +- .../RS/Classical/Deligne/ChainStage2.lean | 8 +- .../RS/Classical/Deligne/ChainUnit.lean | 8 +- .../RS/Classical/Deligne/CharSplit.lean | 8 +- .../RS/Classical/Deligne/CommonAlgebra.lean | 6 +- .../RS/Classical/Deligne/CoprodPreserve.lean | 6 +- .../Classical/Deligne/CountableDescent.lean | 6 +- .../Deligne/CountableDescentClose.lean | 10 +- .../Deligne/CountableNullstellensatz.lean | 6 +- .../RS/Classical/Deligne/CoverFactor.lean | 8 +- .../RS/Classical/Deligne/CycleSplit.lean | 6 +- .../RS/Classical/Deligne/DayCalculus.lean | 6 +- .../RS/Classical/Deligne/DayType.lean | 6 +- .../RS/Classical/Deligne/DeligneAssembly.lean | 10 +- .../RS/Classical/Deligne/DescentClose.lean | 10 +- .../RS/Classical/Deligne/DevissageBound.lean | 12 +- .../RS/Classical/Deligne/DoubledAbelian.lean | 6 +- .../RS/Classical/Deligne/DoubledGrowth.lean | 8 +- .../RS/Classical/Deligne/DoubledLine.lean | 8 +- .../RS/Classical/Deligne/DoubledScalar.lean | 8 +- .../RS/Classical/Deligne/DoubledSmall.lean | 6 +- .../RS/Classical/Deligne/DoubledSplit.lean | 8 +- .../RS/Classical/Deligne/Doubling.lean | 6 +- .../RS/Classical/Deligne/DualityMate.lean | 6 +- .../Classical/Deligne/EvenEmbedMonoidal.lean | 6 +- .../RS/Classical/Deligne/ExactFromShort.lean | 6 +- .../RS/Classical/Deligne/FactorialBeats.lean | 6 +- .../RS/Classical/Deligne/FibreAdditive.lean | 6 +- .../RS/Classical/Deligne/FibreBridge.lean | 8 +- .../RS/Classical/Deligne/FibreEps.lean | 8 +- .../RS/Classical/Deligne/FibreExact.lean | 6 +- .../RS/Classical/Deligne/FibreFaithful.lean | 8 +- .../RS/Classical/Deligne/FibreFunctor.lean | 8 +- .../RS/Classical/Deligne/FibreLinear.lean | 6 +- .../RS/Classical/Deligne/FibreMix.lean | 10 +- .../RS/Classical/Deligne/FibreMonoidal.lean | 12 +- .../RS/Classical/Deligne/FibreMu.lean | 8 +- .../RS/Classical/Deligne/FibreMuNat.lean | 6 +- .../Classical/Deligne/FibreOverComplex.lean | 14 +- .../Classical/Deligne/FibreOverSplitting.lean | 14 +- .../RS/Classical/Deligne/FibreRestrict.lean | 6 +- .../RS/Classical/Deligne/FibreStrong.lean | 8 +- .../RS/Classical/Deligne/FiltNil.lean | 6 +- .../RS/Classical/Deligne/FlatLimit.lean | 6 +- .../RS/Classical/Deligne/FreeCollapseAlg.lean | 6 +- .../RS/Classical/Deligne/FreeMixRetract.lean | 6 +- .../RS/Classical/Deligne/FreeModAdjoint.lean | 8 +- .../RS/Classical/Deligne/FreeModBiprod.lean | 6 +- .../RS/Classical/Deligne/FreeModFunctor.lean | 8 +- .../RS/Classical/Deligne/FreeModShuffle.lean | 10 +- .../Classical/Deligne/FreeModShuffleCoh.lean | 8 +- .../RS/Classical/Deligne/FreeModTensor.lean | 8 +- .../RS/Classical/Deligne/FreeNormalise.lean | 14 +- .../Classical/Deligne/FreeNormaliseBase.lean | 6 +- .../Classical/Deligne/FreeNormaliseStep.lean | 8 +- .../RS/Classical/Deligne/FreePow.lean | 10 +- .../RS/Classical/Deligne/FreePowDesc.lean | 8 +- .../RS/Classical/Deligne/FreePowInsert.lean | 6 +- .../RS/Classical/Deligne/FreeSlide.lean | 6 +- .../RS/Classical/Deligne/FreeSummand.lean | 8 +- .../RS/Classical/Deligne/FreeTwistPi.lean | 8 +- .../RS/Classical/Deligne/GammaAlgebra.lean | 8 +- .../RS/Classical/Deligne/GammaBiprod.lean | 10 +- .../RS/Classical/Deligne/GammaComplex.lean | 8 +- .../RS/Classical/Deligne/GammaCountable.lean | 14 +- .../RS/Classical/Deligne/GammaModule.lean | 6 +- .../Classical/Deligne/GammaModuleFunctor.lean | 6 +- .../RS/Classical/Deligne/GammaPair.lean | 8 +- .../RS/Classical/Deligne/GammaPairAdd.lean | 8 +- .../Classical/Deligne/GammaPairFreeFree.lean | 10 +- .../Classical/Deligne/GammaPairFreeMix.lean | 10 +- .../RS/Classical/Deligne/GammaPairNat.lean | 10 +- .../Classical/Deligne/GammaPairRetract.lean | 8 +- .../Deligne/GammaPairRetractRight.lean | 8 +- .../RS/Classical/Deligne/GammaPairUnit.lean | 14 +- .../RS/Classical/Deligne/GammaShift.lean | 10 +- .../RS/Classical/Deligne/GammaTwistLeft.lean | 8 +- .../Classical/Deligne/GeneratorAlgebra.lean | 12 +- .../RS/Classical/Deligne/GrowthDichotomy.lean | 20 +- .../RS/Classical/Deligne/HomFinite.lean | 6 +- .../RS/Classical/Deligne/HookMult.lean | 6 +- .../RS/Classical/Deligne/HookZero.lean | 6 +- .../RS/Classical/Deligne/IdemCut.lean | 10 +- .../Classical/Deligne/IdempotentLength.lean | 6 +- .../RS/Classical/Deligne/ImageSubalgebra.lean | 6 +- .../RS/Classical/Deligne/IndAllColim.lean | 8 +- .../Classical/Deligne/IndBigTensorUnit.lean | 10 +- .../RS/Classical/Deligne/IndCoeq.lean | 8 +- .../RS/Classical/Deligne/IndCompact.lean | 6 +- .../RS/Classical/Deligne/IndDayClosure.lean | 6 +- .../RS/Classical/Deligne/IndImage.lean | 6 +- .../RS/Classical/Deligne/IndKill.lean | 8 +- .../RS/Classical/Deligne/IndLocallyMixed.lean | 8 +- .../RS/Classical/Deligne/IndMonoidal.lean | 6 +- .../RS/Classical/Deligne/IndOfLinear.lean | 8 +- .../RS/Classical/Deligne/IndOfMonoidal.lean | 6 +- .../RS/Classical/Deligne/IndPointTensor.lean | 10 +- .../RS/Classical/Deligne/IndSchur.lean | 8 +- .../RS/Classical/Deligne/IndSchurKilled.lean | 6 +- .../RS/Classical/Deligne/IndSimple.lean | 8 +- .../RS/Classical/Deligne/IndSplit.lean | 8 +- .../RS/Classical/Deligne/IndSplitSection.lean | 8 +- .../RS/Classical/Deligne/IndTensorExact.lean | 6 +- .../RS/Classical/Deligne/IndUnitNonzero.lean | 8 +- .../RS/Classical/Deligne/InitDatum.lean | 8 +- .../RS/Classical/Deligne/InitState.lean | 8 +- .../RS/Classical/Deligne/InterchangeAct.lean | 8 +- .../RS/Classical/Deligne/KernelPow.lean | 6 +- .../RS/Classical/Deligne/KeyLemma.lean | 10 +- .../RS/Classical/Deligne/KeyLemmaClose.lean | 14 +- .../RS/Classical/Deligne/KeyLemmaData.lean | 6 +- .../RS/Classical/Deligne/KillerNonempty.lean | 8 +- .../RS/Classical/Deligne/KronKill.lean | 6 +- .../RS/Classical/Deligne/LambdaCoend.lean | 6 +- .../RS/Classical/Deligne/MixDegenerate.lean | 6 +- .../RS/Classical/Deligne/MixShuffle.lean | 6 +- .../RS/Classical/Deligne/MixShuffleLine.lean | 6 +- .../RS/Classical/Deligne/MixSumPow.lean | 8 +- .../RS/Classical/Deligne/MixWhisker.lean | 6 +- .../RS/Classical/Deligne/MixWhiskerAll.lean | 8 +- .../RS/Classical/Deligne/MixedConc.lean | 6 +- .../RS/Classical/Deligne/MixedDiag.lean | 8 +- .../RS/Classical/Deligne/MixedTransport.lean | 6 +- .../RS/Classical/Deligne/ModAbelian.lean | 8 +- .../RS/Classical/Deligne/ModAssoc.lean | 6 +- .../RS/Classical/Deligne/ModBiprod.lean | 6 +- .../RS/Classical/Deligne/ModContractL.lean | 6 +- .../RS/Classical/Deligne/ModCross.lean | 6 +- .../RS/Classical/Deligne/ModDual.lean | 6 +- .../RS/Classical/Deligne/ModIns.lean | 6 +- .../RS/Classical/Deligne/ModMulti.lean | 6 +- .../RS/Classical/Deligne/ModMultiTriple.lean | 8 +- .../RS/Classical/Deligne/ModPowCast.lean | 8 +- .../RS/Classical/Deligne/ModPowDescent.lean | 8 +- .../Classical/Deligne/ModPowDescentClose.lean | 6 +- .../RS/Classical/Deligne/ModPowStage.lean | 6 +- .../RS/Classical/Deligne/ModSchur.lean | 12 +- .../RS/Classical/Deligne/ModSchurSummand.lean | 8 +- .../RS/Classical/Deligne/ModTensor.lean | 6 +- .../RS/Classical/Deligne/ModZero.lean | 8 +- .../RS/Classical/Deligne/MuInterchange.lean | 6 +- .../RS/Classical/Deligne/MulBy.lean | 6 +- .../RS/Classical/Deligne/NatChain.lean | 6 +- .../RS/Classical/Deligne/NewtonConv.lean | 6 +- .../RS/Classical/Deligne/NullPoint.lean | 6 +- .../RS/Classical/Deligne/OddLineMap.lean | 6 +- .../RS/Classical/Deligne/OddLinePairing.lean | 6 +- .../RS/Classical/Deligne/OddParity.lean | 6 +- .../RS/Classical/Deligne/OddPermSign.lean | 6 +- .../RS/Classical/Deligne/OddSquare.lean | 6 +- .../RS/Classical/Deligne/OddSquareIso.lean | 12 +- .../RS/Classical/Deligne/PairCarrier.lean | 6 +- .../RS/Classical/Deligne/PairMul.lean | 6 +- .../RS/Classical/Deligne/PairPerm.lean | 6 +- .../RS/Classical/Deligne/PermNat.lean | 10 +- .../RS/Classical/Deligne/PermRepChar.lean | 10 +- .../RS/Classical/Deligne/PieriPos.lean | 10 +- .../RS/Classical/Deligne/PlainShuffle.lean | 6 +- .../RS/Classical/Deligne/PointBaseChange.lean | 10 +- .../RS/Classical/Deligne/PointFibre.lean | 8 +- .../RS/Classical/Deligne/PointMonoidal.lean | 4 +- .../Deligne/PointMonoidal/Calculus.lean | 6 +- .../Deligne/PointMonoidal/Coherence.lean | 6 +- .../Deligne/PointMonoidal/Comparison.lean | 6 +- .../Deligne/PointMonoidal/Functor.lean | 6 +- .../Deligne/PointMonoidal/Residue.lean | 6 +- .../RS/Classical/Deligne/PointTensor.lean | 6 +- .../RS/Classical/Deligne/PowAct.lean | 6 +- .../RS/Classical/Deligne/PowActMul.lean | 6 +- .../RS/Classical/Deligne/PowChain.lean | 6 +- .../RS/Classical/Deligne/PowCopairing.lean | 6 +- .../RS/Classical/Deligne/PowDatum.lean | 8 +- .../RS/Classical/Deligne/PowInduct.lean | 12 +- .../RS/Classical/Deligne/PowMerge.lean | 6 +- .../RS/Classical/Deligne/PowPairSucc.lean | 6 +- .../RS/Classical/Deligne/PowPairing.lean | 8 +- .../RS/Classical/Deligne/PowPoint.lean | 10 +- .../RS/Classical/Deligne/PowSucc.lean | 8 +- .../RS/Classical/Deligne/PowSuccMod.lean | 6 +- .../RS/Classical/Deligne/PowTriangle.lean | 8 +- .../RS/Classical/Deligne/PowZig.lean | 6 +- .../RS/Classical/Deligne/PowZigzag.lean | 6 +- .../Classical/Deligne/PresentedQuotient.lean | 6 +- .../RS/Classical/Deligne/Prop21.lean | 10 +- .../RS/Classical/Deligne/Prop21Core.lean | 14 +- .../RS/Classical/Deligne/Prop21General.lean | 18 +- .../RS/Classical/Deligne/Prop29.lean | 10 +- .../RS/Classical/Deligne/Prop29Close.lean | 14 +- .../RS/Classical/Deligne/Prop29State.lean | 10 +- .../RS/Classical/Deligne/Rappel210.lean | 6 +- .../RS/Classical/Deligne/Rappel210Bridge.lean | 10 +- .../RS/Classical/Deligne/Rappel210Chain.lean | 8 +- .../RS/Classical/Deligne/Rappel210Close.lean | 8 +- .../RS/Classical/Deligne/Rappel210Ind.lean | 8 +- .../RS/Classical/Deligne/Rappel210Reduce.lean | 8 +- .../RS/Classical/Deligne/RegularSum.lean | 10 +- .../RS/Classical/Deligne/RhoBiprod.lean | 6 +- .../RS/Classical/Deligne/RhoTwist.lean | 6 +- .../RS/Classical/Deligne/RowColIdem.lean | 8 +- .../RS/Classical/Deligne/SandwichMerge.lean | 10 +- .../RS/Classical/Deligne/SandwichRetract.lean | 8 +- .../RS/Classical/Deligne/SandwichZig.lean | 8 +- .../RS/Classical/Deligne/ScalarBraiding.lean | 8 +- .../RS/Classical/Deligne/ScalarLinear.lean | 8 +- .../RS/Classical/Deligne/ScalarUnitEquiv.lean | 6 +- .../RS/Classical/Deligne/ScalarUnitInd.lean | 6 +- .../RS/Classical/Deligne/SchurTransport.lean | 10 +- .../RS/Classical/Deligne/SchurVanishing.lean | 6 +- .../RS/Classical/Deligne/SeedIns.lean | 8 +- .../RS/Classical/Deligne/ShapeAlgebra.lean | 8 +- .../RS/Classical/Deligne/ShapeFintype.lean | 6 +- .../RS/Classical/Deligne/SignConj.lean | 10 +- .../RS/Classical/Deligne/SimpleGenerator.lean | 8 +- .../RS/Classical/Deligne/SimplePoint.lean | 6 +- .../RS/Classical/Deligne/SimpleQuotient.lean | 8 +- .../RS/Classical/Deligne/SimpleScalars.lean | 8 +- .../RS/Classical/Deligne/SimpleSplit.lean | 14 +- .../RS/Classical/Deligne/SmallReduction.lean | 6 +- .../RS/Classical/Deligne/SplitAdjoint.lean | 6 +- .../RS/Classical/Deligne/SplitAssemble.lean | 6 +- .../RS/Classical/Deligne/SplitClosure.lean | 8 +- .../RS/Classical/Deligne/SplitComplement.lean | 8 +- .../RS/Classical/Deligne/SplitEverything.lean | 16 +- .../RS/Classical/Deligne/SplitExact.lean | 8 +- .../RS/Classical/Deligne/SplitExtract.lean | 6 +- .../Classical/Deligne/SplitExtractDual.lean | 6 +- .../RS/Classical/Deligne/SplitMonHom.lean | 6 +- .../RS/Classical/Deligne/SplitPairDef.lean | 8 +- .../RS/Classical/Deligne/SplitReduce.lean | 6 +- .../RS/Classical/Deligne/SplitTransport.lean | 8 +- .../Classical/Deligne/SplittingAlgebra.lean | 8 +- .../RS/Classical/Deligne/StateTransport.lean | 8 +- .../RS/Classical/Deligne/StepA.lean | 10 +- .../RS/Classical/Deligne/StepATransport.lean | 10 +- .../RS/Classical/Deligne/StepB.lean | 10 +- .../RS/Classical/Deligne/SuperEmbed.lean | 4 +- .../Classical/Deligne/SuperEmbed/Letters.lean | 6 +- .../Classical/Deligne/SuperEmbed/Signs.lean | 8 +- .../Deligne/SuperEmbed/Standard.lean | 6 +- .../RS/Classical/Deligne/SuperEvenRing.lean | 8 +- .../RS/Classical/Deligne/SuperGamma.lean | 6 +- .../RS/Classical/Deligne/SuperGammaInst.lean | 10 +- .../RS/Classical/Deligne/SuperModAbelian.lean | 6 +- .../RS/Classical/Deligne/SuperModBiprod.lean | 6 +- .../Classical/Deligne/SuperModBiprodMap.lean | 8 +- .../RS/Classical/Deligne/SuperModHom.lean | 6 +- .../RS/Classical/Deligne/SuperModIso.lean | 6 +- .../Classical/Deligne/SuperModMonoidal.lean | 8 +- .../RS/Classical/Deligne/SuperModShift.lean | 6 +- .../Classical/Deligne/SuperModShiftUnit.lean | 8 +- .../RS/Classical/Deligne/SuperModTensor.lean | 6 +- .../RS/Classical/Deligne/SuperPointMod.lean | 8 +- .../RS/Classical/Deligne/SuperRealize.lean | 6 +- .../RS/Classical/Deligne/SuperSeries.lean | 8 +- .../RS/Classical/Deligne/SuperSmall.lean | 6 +- .../RS/Classical/Deligne/SuperValues.lean | 8 +- .../RS/Classical/Deligne/SuperVectSchur.lean | 10 +- .../RS/Classical/Deligne/SymAlg.lean | 8 +- .../RS/Classical/Deligne/SymDatum.lean | 6 +- .../RS/Classical/Deligne/SymMul.lean | 6 +- .../RS/Classical/Deligne/TensorDatum.lean | 6 +- .../RS/Classical/Deligne/TensorExact.lean | 6 +- .../RS/Classical/Deligne/TensorMuBraid.lean | 6 +- .../RS/Classical/Deligne/TensorPowZero.lean | 8 +- .../RS/Classical/Deligne/TensorTransfer.lean | 10 +- .../RS/Classical/Deligne/TensorZigzag.lean | 10 +- .../RS/Classical/Deligne/TrichotomyClose.lean | 8 +- .../RS/Classical/Deligne/TwistBiprod.lean | 8 +- .../RS/Classical/Deligne/TwistCoherence.lean | 6 +- .../RS/Classical/Deligne/TwistDatum.lean | 20 +- .../RS/Classical/Deligne/TwistFreeTensor.lean | 8 +- .../RS/Classical/Deligne/TwistMixLine.lean | 6 +- .../RS/Classical/Deligne/TwistPow.lean | 10 +- .../RS/Classical/Deligne/TwistShuffle.lean | 8 +- .../RS/Classical/Deligne/TwistState.lean | 12 +- .../RS/Classical/Deligne/TwistSymPow.lean | 8 +- .../RS/Classical/Deligne/TwistUnitor.lean | 8 +- .../RS/Classical/Deligne/UnitBase.lean | 6 +- .../RS/Classical/Deligne/UnitFreeMod.lean | 6 +- .../RS/Classical/Deligne/UnitMod.lean | 6 +- .../RS/Classical/Deligne/UnitSimple.lean | 6 +- .../RS/Classical/Deligne/UnitStage.lean | 6 +- .../Classical/Deligne/UniversalAlgebra.lean | 8 +- .../RS/Classical/Deligne/WhiskerFaithful.lean | 8 +- .../RS/Classical/Deligne/WordMap.lean | 6 +- .../RS/Classical/Deligne/ZagAction.lean | 8 +- .../RS/Classical/Deligne/ZigzagCarrier.lean | 6 +- .../RS/Classical/Deligne/ZigzagNonzero.lean | 6 +- .../RS/Classical/Deligne/ZigzagSandwich.lean | 8 +- .../RS/Classical/Deligne/ZigzagTransfer.lean | 10 +- .../Classical/Deligne/ZigzagTransferIso.lean | 6 +- .../Classical/Interfaces/DeligneBridge.lean | 10 +- .../Classical/Interfaces/DelignePackage.lean | 6 +- .../Interfaces/DelignePackageRestrict.lean | 6 +- .../Classical/Interfaces/DeligneTheorem.lean | 8 +- .../Interfaces/EulerianIndependence.lean | 6 +- .../Classical/Interfaces/FibreTransport.lean | 6 +- .../RS/Classical/Interfaces/KoszulAction.lean | 6 +- .../RS/Classical/Interfaces/OmegaPerm.lean | 12 +- .../Interfaces/OmegaTensorPower.lean | 8 +- .../RS/Classical/Interfaces/SchurPackage.lean | 8 +- .../Classical/Interfaces/SectorDischarge.lean | 10 +- .../Interfaces/SectorIntertwine.lean | 10 +- .../Classical/Interfaces/TotalDimension.lean | 16 +- .../RS/Classical/SchurTheory/BlockKill.lean | 6 +- .../RS/Classical/SchurTheory/BranchTrace.lean | 6 +- .../RS/Classical/SchurTheory/CentralElem.lean | 6 +- .../RS/Classical/SchurTheory/CharClass.lean | 6 +- .../RS/Classical/SchurTheory/CharDecomp.lean | 8 +- .../RS/Classical/SchurTheory/CharEquiv.lean | 6 +- .../Classical/SchurTheory/ColourCycleSum.lean | 10 +- .../Classical/SchurTheory/ColourWeight.lean | 8 +- .../Classical/SchurTheory/CommutantBound.lean | 8 +- .../Classical/SchurTheory/ContentCount.lean | 6 +- .../RS/Classical/SchurTheory/CycleFactor.lean | 6 +- .../RS/Classical/SchurTheory/CycleSum.lean | 12 +- .../Classical/SchurTheory/CycleSumPrep.lean | 6 +- .../RS/Classical/SchurTheory/EndSum.lean | 6 +- .../RS/Classical/SchurTheory/FibreCard.lean | 6 +- .../RS/Classical/SchurTheory/FixWeight.lean | 8 +- .../RS/Classical/SchurTheory/HVal.lean | 6 +- .../SchurTheory/IdempotentBridge.lean | 8 +- .../RS/Classical/SchurTheory/JTChar.lean | 8 +- .../RS/Classical/SchurTheory/JTIntChar.lean | 8 +- .../Classical/SchurTheory/JTIrreducible.lean | 10 +- .../RS/Classical/SchurTheory/JTOrtho.lean | 12 +- .../RS/Classical/SchurTheory/JTPad.lean | 6 +- .../RS/Classical/SchurTheory/JTSimple.lean | 8 +- .../RS/Classical/SchurTheory/KillSimples.lean | 6 +- .../RS/Classical/SchurTheory/MixedCount.lean | 8 +- .../RS/Classical/SchurTheory/MixedFixed.lean | 6 +- .../Classical/SchurTheory/NativeAction.lean | 8 +- .../Classical/SchurTheory/NativeFaithful.lean | 6 +- .../RS/Classical/SchurTheory/NativeTable.lean | 6 +- .../RS/Classical/SchurTheory/OrbitBridge.lean | 6 +- .../RS/Classical/SchurTheory/Package.lean | 10 +- .../SchurTheory/PackageAssembly.lean | 10 +- .../RS/Classical/SchurTheory/PairChar.lean | 6 +- .../RS/Classical/SchurTheory/PairInner.lean | 6 +- .../RS/Classical/SchurTheory/PairOrbit.lean | 6 +- .../RS/Classical/SchurTheory/PairStab.lean | 6 +- .../RS/Classical/SchurTheory/PairTuple.lean | 6 +- .../RS/Classical/SchurTheory/PairingPos.lean | 12 +- .../RS/Classical/SchurTheory/PermModule.lean | 6 +- .../RS/Classical/SchurTheory/PowerSurj.lean | 6 +- .../Classical/SchurTheory/RegularTrace.lean | 6 +- .../Classical/SchurTheory/SameCycleQuot.lean | 6 +- .../RS/Classical/SchurTheory/ScalarTrace.lean | 6 +- .../RS/Classical/SchurTheory/SchurAction.lean | 6 +- .../Classical/SchurTheory/SigmaCycleType.lean | 6 +- .../RS/Classical/SchurTheory/SignResolve.lean | 8 +- .../Classical/SchurTheory/SignedTensor.lean | 10 +- .../RS/Classical/SchurTheory/SimpleEmbed.lean | 6 +- .../Classical/SchurTheory/SquareGrowth.lean | 6 +- .../SchurTheory/SquareGrowthSharp.lean | 6 +- .../RS/Classical/SchurTheory/SquareStair.lean | 6 +- .../RS/Classical/SchurTheory/StabCount.lean | 6 +- .../SchurTheory/TensorNonvanishing.lean | 6 +- .../RS/Classical/SchurTheory/TensorTrace.lean | 6 +- .../Classical/SchurTheory/WordCommutant.lean | 6 +- .../RS/Classical/Super/ColourAction.lean | 8 +- .../RS/Classical/Super/ColourConj.lean | 8 +- .../RS/Classical/Super/ColourConjStep.lean | 6 +- .../RS/Classical/Super/ColourConjTop.lean | 8 +- .../RS/Classical/Super/ColourEval.lean | 6 +- .../RS/Classical/Super/ColourExtendSwap.lean | 6 +- .../RS/Classical/Super/ColourFormMatch.lean | 6 +- .../RS/Classical/Super/ColourMerge.lean | 8 +- .../RS/Classical/Super/ColourMergeOdd.lean | 6 +- .../RS/Classical/Super/ColourPairing.lean | 6 +- .../RS/Classical/Super/ColourPairingSymm.lean | 6 +- .../RS/Classical/Super/ColourPower.lean | 6 +- .../RS/Classical/Super/ColourTotal.lean | 8 +- .../RS/Classical/Super/ColourWord.lean | 8 +- .../RS/Classical/Super/OrthonormalBasis.lean | 6 +- .../RS/Classical/Super/PowBraid.lean | 6 +- .../RS/Classical/Super/SuperVect.lean | 6 +- .../RS/Classical/Super/SymplecticBasis.lean | 6 +- .../RS/Classical/Super/TotalSpace.lean | 6 +- .../RS/Classical/Super/WordSignPerm.lean | 6 +- .../RS/Classical/SymFun/AlternantExpand.lean | 6 +- .../RS/Classical/SymFun/AlternantPieri.lean | 6 +- .../RS/Classical/SymFun/AlternantStrict.lean | 6 +- .../RS/Classical/SymFun/Bialternant.lean | 6 +- .../RS/Classical/SymFun/BinomialDet.lean | 8 +- .../RS/Classical/SymFun/BinomialH.lean | 6 +- .../RS/Classical/SymFun/CoeffExtract.lean | 6 +- .../RS/Classical/SymFun/CoeffSplit.lean | 6 +- .../RS/Classical/SymFun/DeltaSeq.lean | 6 +- .../RS/Classical/SymFun/DescVandermonde.lean | 6 +- .../RS/Classical/SymFun/DimFormula.lean | 8 +- .../RS/Classical/SymFun/EHConv.lean | 6 +- .../RS/Classical/SymFun/EHDischarge.lean | 8 +- .../RS/Classical/SymFun/HInsert.lean | 6 +- .../RS/Classical/SymFun/HProdCoeff.lean | 6 +- .../RS/Classical/SymFun/HSubZ.lean | 6 +- .../RS/Classical/SymFun/HookVanishing.lean | 10 +- .../RS/Classical/SymFun/JTDetExpand.lean | 6 +- .../RS/Classical/SymFun/JTGuard.lean | 6 +- .../RS/Classical/SymFun/LGVStrict.lean | 6 +- .../RS/Classical/SymFun/PieriChain.lean | 8 +- .../RS/Classical/SymFun/PowCount.lean | 6 +- .../RS/Classical/SymFun/PowerSums.lean | 6 +- .../SymFun/RationalityFromRecurrence.lean | 6 +- .../SymFun/RecurrenceFromVanishing.lean | 6 +- .../RS/Classical/SymFun/SubsetEH.lean | 6 +- .../RS/Classical/SymFun/SuperPowerSums.lean | 6 +- .../RS/Classical/SymFun/TCount.lean | 8 +- .../RS/Classical/SymFun/TIdentity.lean | 6 +- .../RS/Classical/SymFun/ZetaExp.lean | 6 +- .../RS/Classical/SymFun/ZetaRational.lean | 6 +- .../RS/Classical/SymFun/ZetaSeries.lean | 6 +- LeanPool/RegtsSevenster/RS/Common.lean | 38 +- .../RS/Common/DiagramChain.lean | 6 +- .../RS/Common/ExponentialGrowth.lean | 6 +- .../RS/Common/FactorialBound.lean | 6 +- .../RegtsSevenster/RS/Common/FinSlots.lean | 6 +- .../RegtsSevenster/RS/Common/ListAttach.lean | 6 +- .../RegtsSevenster/RS/Common/ListPairs.lean | 6 +- .../RegtsSevenster/RS/Common/ListSign.lean | 6 +- .../RegtsSevenster/RS/Common/MathlibDeps.lean | 248 +-- .../RS/Common/NilpotentMap.lean | 6 +- .../RS/Common/NilpotentPowerTrace.lean | 6 +- .../RS/Common/PairDisjoint.lean | 6 +- .../RegtsSevenster/RS/Common/PermCongr.lean | 6 +- .../RS/Common/PermTopSplit.lean | 6 +- .../RegtsSevenster/RS/Common/ProdSum.lean | 6 +- .../RegtsSevenster/RS/Common/RowLenChain.lean | 6 +- .../RegtsSevenster/RS/Common/RowSpanRank.lean | 6 +- .../RS/Common/TraceSeparation.lean | 6 +- .../RS/Common/YoungDiagrams.lean | 6 +- LeanPool/RegtsSevenster/RS/Definitions.lean | 8 +- .../RS/DimensionDefinitions.lean | 6 +- LeanPool/RegtsSevenster/RS/Glossary.lean | 4 +- LeanPool/RegtsSevenster/RS/Novel.lean | 668 +++---- .../RS/Novel/Coordinates/AdjSwapBmc.lean | 8 +- .../RS/Novel/Coordinates/AdjacentWord.lean | 6 +- .../RS/Novel/Coordinates/BasisCoord.lean | 8 +- .../RS/Novel/Coordinates/BasisSplit.lean | 6 +- .../RS/Novel/Coordinates/BetaData.lean | 6 +- .../RS/Novel/Coordinates/BetaDiag.lean | 8 +- .../RS/Novel/Coordinates/BetaDiagForm.lean | 8 +- .../RS/Novel/Coordinates/BetaFlip.lean | 14 +- .../RS/Novel/Coordinates/BlockAlign.lean | 10 +- .../RS/Novel/Coordinates/BlockCanon.lean | 10 +- .../RS/Novel/Coordinates/BlockData.lean | 6 +- .../RS/Novel/Coordinates/BlockOddList.lean | 8 +- .../RS/Novel/Coordinates/BlockParity.lean | 6 +- .../RS/Novel/Coordinates/BlockRestrict.lean | 8 +- .../RS/Novel/Coordinates/BlockSigma.lean | 6 +- .../RS/Novel/Coordinates/BlockSort.lean | 6 +- .../RS/Novel/Coordinates/BraidWord.lean | 6 +- .../RS/Novel/Coordinates/CanonColour.lean | 6 +- .../RS/Novel/Coordinates/CanonPerm.lean | 8 +- .../RS/Novel/Coordinates/CapClosed.lean | 8 +- .../RS/Novel/Coordinates/CapExpansion.lean | 6 +- .../RS/Novel/Coordinates/CapFun.lean | 8 +- .../RS/Novel/Coordinates/CapMatch.lean | 6 +- .../RS/Novel/Coordinates/CapPeel.lean | 6 +- .../RS/Novel/Coordinates/CapPeelSplit.lean | 6 +- .../RS/Novel/Coordinates/CapPerm.lean | 6 +- .../RS/Novel/Coordinates/CapSplit.lean | 6 +- .../RS/Novel/Coordinates/CapVal.lean | 6 +- .../RS/Novel/Coordinates/ChainLists.lean | 6 +- .../RS/Novel/Coordinates/CircleModel.lean | 8 +- .../RS/Novel/Coordinates/CircleScalar.lean | 8 +- .../RS/Novel/Coordinates/CircuitCount.lean | 6 +- .../Novel/Coordinates/ClosedTransition.lean | 8 +- .../RS/Novel/Coordinates/ConcatSign.lean | 6 +- .../RS/Novel/Coordinates/CoordInterface.lean | 6 +- .../RS/Novel/Coordinates/CoordOf.lean | 8 +- .../RS/Novel/Coordinates/CoreParity.lean | 18 +- .../RS/Novel/Coordinates/EdgeSign.lean | 8 +- .../RS/Novel/Coordinates/EvForm.lean | 6 +- .../RS/Novel/Coordinates/EvFormOdd.lean | 8 +- .../RS/Novel/Coordinates/EvLeaf.lean | 6 +- .../RS/Novel/Coordinates/FibreParam.lean | 6 +- .../RS/Novel/Coordinates/FlagEnum.lean | 8 +- .../RS/Novel/Coordinates/GlobalSlotList.lean | 8 +- .../RS/Novel/Coordinates/HRS.lean | 8 +- .../RS/Novel/Coordinates/IndexPerm.lean | 6 +- .../RS/Novel/Coordinates/ListSignPerm.lean | 8 +- .../RS/Novel/Coordinates/MasterSum.lean | 6 +- .../RS/Novel/Coordinates/ModelCoord.lean | 10 +- .../RS/Novel/Coordinates/ModelPermCoord.lean | 8 +- .../RS/Novel/Coordinates/ModelStarVec.lean | 6 +- .../RS/Novel/Coordinates/MultiStar.lean | 6 +- .../RS/Novel/Coordinates/NFDef.lean | 6 +- .../RS/Novel/Coordinates/NFValue.lean | 8 +- .../RS/Novel/Coordinates/OddFlip.lean | 6 +- .../RS/Novel/Coordinates/OddListMultiset.lean | 6 +- .../RS/Novel/Coordinates/OddPair.lean | 6 +- .../RS/Novel/Coordinates/OddSignProd.lean | 6 +- .../RS/Novel/Coordinates/OmegaCotensor.lean | 6 +- .../RS/Novel/Coordinates/OmegaStarVec.lean | 6 +- .../RS/Novel/Coordinates/OmegaTensor.lean | 6 +- .../RS/Novel/Coordinates/OmegaTransport.lean | 12 +- .../RS/Novel/Coordinates/OneBasis.lean | 6 +- .../RS/Novel/Coordinates/OrbitCard.lean | 6 +- .../RS/Novel/Coordinates/OutSignEdges.lean | 6 +- .../RS/Novel/Coordinates/PairEnum.lean | 6 +- .../RS/Novel/Coordinates/PairList.lean | 8 +- .../RS/Novel/Coordinates/ParameterModel.lean | 6 +- .../RS/Novel/Coordinates/PatternInv.lean | 6 +- .../RS/Novel/Coordinates/PowMerge.lean | 6 +- .../RS/Novel/Coordinates/RegroupSign.lean | 10 +- .../RS/Novel/Coordinates/Reindex.lean | 10 +- .../RS/Novel/Coordinates/ReindexBij.lean | 6 +- .../RS/Novel/Coordinates/ReindexHeart.lean | 8 +- .../RS/Novel/Coordinates/ReindexVanish.lean | 10 +- .../RS/Novel/Coordinates/RepFlag.lean | 6 +- .../RS/Novel/Coordinates/RiffleSign.lean | 8 +- .../RS/Novel/Coordinates/SignPair.lean | 8 +- .../RS/Novel/Coordinates/SkeinPowBraid.lean | 8 +- .../RS/Novel/Coordinates/SlotPairing.lean | 6 +- .../RS/Novel/Coordinates/SortFactor.lean | 8 +- .../RS/Novel/Coordinates/SortPerm.lean | 6 +- .../RS/Novel/Coordinates/StarClassFactor.lean | 6 +- .../RS/Novel/Coordinates/StarPeel.lean | 6 +- .../RS/Novel/Coordinates/StarPerm.lean | 6 +- .../RS/Novel/Coordinates/StarRepeat.lean | 6 +- .../RS/Novel/Coordinates/StarSymm.lean | 6 +- .../RS/Novel/Coordinates/StarTensorClass.lean | 6 +- .../RS/Novel/Coordinates/StdTransport.lean | 8 +- .../RS/Novel/Coordinates/StrandTransport.lean | 6 +- .../RS/Novel/Coordinates/TauCount.lean | 8 +- .../RS/Novel/Coordinates/TauKey.lean | 10 +- .../RS/Novel/Coordinates/TopBraidMerge.lean | 6 +- .../RS/Novel/Coordinates/TwoBasis.lean | 6 +- .../RS/Novel/Coordinates/VertexSign.lean | 8 +- .../RS/Novel/Coordinates/VertexValue.lean | 6 +- .../RS/Novel/Envelope/AtomDichotomy.lean | 8 +- .../RS/Novel/Envelope/AtomicIdempotents.lean | 6 +- .../RS/Novel/Envelope/BlockAssembly.lean | 8 +- .../RS/Novel/Envelope/BlockBounds.lean | 6 +- .../RS/Novel/Envelope/BlockCycle.lean | 10 +- .../RS/Novel/Envelope/BlockFactor.lean | 6 +- .../Novel/Envelope/BlockFactorialTrace.lean | 10 +- .../RS/Novel/Envelope/BlockSplice.lean | 10 +- .../RS/Novel/Envelope/BlockTower.lean | 8 +- .../RS/Novel/Envelope/CycleNormal.lean | 6 +- .../RS/Novel/Envelope/CycleTrace.lean | 8 +- .../RS/Novel/Envelope/EnvAbelian.lean | 6 +- .../RS/Novel/Envelope/EnvDeligne.lean | 10 +- .../RS/Novel/Envelope/EnvDelignePackage.lean | 22 +- .../RS/Novel/Envelope/EnvGenerator.lean | 8 +- .../RS/Novel/Envelope/EnvGrowth.lean | 8 +- .../RS/Novel/Envelope/EnvInstances.lean | 10 +- .../RS/Novel/Envelope/EnvSemisimple.lean | 6 +- .../RS/Novel/Envelope/FactorialTrace.lean | 8 +- .../RS/Novel/Envelope/Frobenius.lean | 12 +- .../RS/Novel/Envelope/HookConfinement.lean | 6 +- .../Novel/Envelope/HookConfinementSharp.lean | 10 +- .../RS/Novel/Envelope/KaroubiEmbBraided.lean | 6 +- .../RS/Novel/Envelope/KaroubiMonoidal.lean | 6 +- .../RS/Novel/Envelope/KaroubiRigid.lean | 6 +- .../RS/Novel/Envelope/KaroubiSemisimple.lean | 10 +- .../RS/Novel/Envelope/MatBraided.lean | 6 +- .../RS/Novel/Envelope/MatEmbMonoidal.lean | 8 +- .../RS/Novel/Envelope/MatMonoidal.lean | 6 +- .../RS/Novel/Envelope/MatRigid.lean | 6 +- .../RS/Novel/Envelope/MatSemisimple.lean | 6 +- .../RS/Novel/Envelope/NilpotentMatTrace.lean | 6 +- .../RS/Novel/Envelope/NilpotentTrace.lean | 8 +- .../RS/Novel/Envelope/ObjectTower.lean | 12 +- .../RS/Novel/Envelope/PermTrace.lean | 8 +- .../RS/Novel/Envelope/RankDimension.lean | 8 +- .../RS/Novel/Envelope/ScalarPermTrace.lean | 8 +- .../RS/Novel/Envelope/ScalarTrace.lean | 8 +- .../RS/Novel/Envelope/SemisimpleAll.lean | 8 +- .../RS/Novel/Envelope/SemisimpleEnd.lean | 4 +- .../RS/Novel/Envelope/SkeinDimBound.lean | 10 +- .../RS/Novel/Envelope/SkeinTower.lean | 12 +- .../RS/Novel/Envelope/SkeinTrace.lean | 12 +- .../RS/Novel/Envelope/SuperKill.lean | 8 +- .../RS/Novel/Envelope/SymPerm.lean | 10 +- .../RS/Novel/Envelope/SymPermCast.lean | 6 +- .../RS/Novel/Envelope/TensorPowHom.lean | 6 +- .../RS/Novel/Envelope/TensorPowSplit.lean | 8 +- .../RS/Novel/Envelope/TraceZeta.lean | 10 +- .../RS/Novel/Envelope/TraceZetaSharp.lean | 8 +- .../RS/Novel/Extraction/CircleValue.lean | 6 +- .../RS/Novel/Extraction/CoordIso.lean | 6 +- .../RS/Novel/Extraction/Coordinates.lean | 10 +- .../RS/Novel/Extraction/CopairUnique.lean | 8 +- .../RS/Novel/Extraction/Nondegenerate.lean | 6 +- .../RS/Novel/Extraction/SnakeTransport.lean | 8 +- .../RS/Novel/Extraction/StdDuality.lean | 8 +- .../RS/Novel/Extraction/StdRigid.lean | 6 +- .../RS/Novel/Extraction/StdSuper.lean | 6 +- .../RS/Novel/Skein/AllInternalAgreement.lean | 8 +- .../Novel/Skein/AllInternalIndependence.lean | 6 +- .../RS/Novel/Skein/BraidedInstance.lean | 6 +- .../RS/Novel/Skein/BraidedNat.lean | 6 +- .../RS/Novel/Skein/BundleClose.lean | 8 +- .../RS/Novel/Skein/BundleMapClasses.lean | 10 +- .../RS/Novel/Skein/BundleTensor.lean | 6 +- .../RS/Novel/Skein/CanonExistence.lean | 6 +- .../RS/Novel/Skein/CanonTransport.lean | 6 +- .../RS/Novel/Skein/CanonicalFrame.lean | 8 +- .../RS/Novel/Skein/ChainAgreement.lean | 6 +- .../RS/Novel/Skein/ChordCount.lean | 6 +- .../RS/Novel/Skein/ChordLabels.lean | 8 +- .../RS/Novel/Skein/ChordParity.lean | 8 +- .../RS/Novel/Skein/ChordSwapParity.lean | 8 +- .../RS/Novel/Skein/CloseRotate.lean | 6 +- .../RS/Novel/Skein/CloseRotateLeft.lean | 6 +- .../RS/Novel/Skein/CloseUnion.lean | 12 +- .../RS/Novel/Skein/ClosedAgreement.lean | 10 +- .../RS/Novel/Skein/ClosedCutDispatch.lean | 12 +- .../RS/Novel/Skein/ClosedIdentify.lean | 8 +- .../RS/Novel/Skein/ClosedTopSum.lean | 6 +- .../RS/Novel/Skein/ColourEmbedding.lean | 8 +- .../RS/Novel/Skein/ColourGlue.lean | 8 +- .../RS/Novel/Skein/ColourPadding.lean | 8 +- .../RS/Novel/Skein/ColourRecursion.lean | 8 +- .../RS/Novel/Skein/ComposeAssoc.lean | 6 +- .../RS/Novel/Skein/ComposeNormal.lean | 6 +- .../RS/Novel/Skein/ComposeRelabel.lean | 8 +- .../RS/Novel/Skein/Composition.lean | 6 +- .../RS/Novel/Skein/CompositionEquiv.lean | 6 +- .../RS/Novel/Skein/ConnectionRank.lean | 8 +- .../RS/Novel/Skein/ConverseAssembly.lean | 10 +- .../RS/Novel/Skein/ConverseDischarge.lean | 6 +- .../RS/Novel/Skein/ConverseFamily.lean | 6 +- .../RS/Novel/Skein/ConverseGram.lean | 8 +- .../RS/Novel/Skein/ConverseIdentity.lean | 8 +- .../RS/Novel/Skein/ConverseLift.lean | 8 +- .../RS/Novel/Skein/ConversePair.lean | 6 +- .../RS/Novel/Skein/ConverseTrip.lean | 6 +- .../RS/Novel/Skein/CrossingDelta.lean | 6 +- .../RS/Novel/Skein/CutMatching.lean | 14 +- .../RS/Novel/Skein/CutSubsetSum.lean | 6 +- .../RS/Novel/Skein/DirMatching.lean | 8 +- .../RS/Novel/Skein/DisjSubsetSplit.lean | 6 +- .../RS/Novel/Skein/DisjUnionFactor.lean | 4 +- .../RS/Novel/Skein/DisjUnionFactor/A.lean | 12 +- .../RS/Novel/Skein/DisjUnionFactor/B.lean | 6 +- .../RS/Novel/Skein/DisjUnionFactor/C.lean | 6 +- .../RS/Novel/Skein/DisjUnionProduct.lean | 18 +- .../RS/Novel/Skein/EdgeColouring.lean | 8 +- .../RS/Novel/Skein/EdgeSum.lean | 6 +- .../RS/Novel/Skein/EdgeTerm.lean | 8 +- .../RS/Novel/Skein/Eulerian.lean | 8 +- .../RS/Novel/Skein/ExactPairingInstance.lean | 8 +- .../RS/Novel/Skein/FibreValue.lean | 8 +- .../RS/Novel/Skein/FlagGraph.lean | 6 +- .../RS/Novel/Skein/FlipSignForm.lean | 6 +- .../RS/Novel/Skein/FlipSignProduct.lean | 6 +- .../RS/Novel/Skein/FourLabelParity.lean | 6 +- .../RS/Novel/Skein/FragmentEquiv.lean | 6 +- .../RS/Novel/Skein/GenBoundaryStates.lean | 6 +- .../RS/Novel/Skein/GlueAmbient.lean | 8 +- .../RS/Novel/Skein/GlueChord.lean | 8 +- .../RS/Novel/Skein/GlueChords.lean | 6 +- .../RS/Novel/Skein/GlueCircuitDelta.lean | 6 +- .../RS/Novel/Skein/GlueComm.lean | 6 +- .../RS/Novel/Skein/GlueCrossDelta.lean | 6 +- .../RS/Novel/Skein/GlueFold.lean | 8 +- .../RS/Novel/Skein/GlueLedger.lean | 6 +- .../RS/Novel/Skein/GluePathMatch.lean | 6 +- .../RS/Novel/Skein/GlueRelTransport.lean | 6 +- .../RS/Novel/Skein/GlueSplit.lean | 6 +- .../RS/Novel/Skein/GlueSplitProof.lean | 4 +- .../RS/Novel/Skein/GlueSplitProof/A.lean | 6 +- .../RS/Novel/Skein/GlueSplitProof/C.lean | 6 +- .../RS/Novel/Skein/GlueSubsetBij.lean | 6 +- .../RS/Novel/Skein/GramRank.lean | 6 +- .../RS/Novel/Skein/HomCompose.lean | 6 +- .../RS/Novel/Skein/HomSpaces.lean | 6 +- .../RS/Novel/Skein/HomTensor.lean | 6 +- .../RS/Novel/Skein/HomTraceCyclic.lean | 6 +- .../RS/Novel/Skein/HomTraceNondegenerate.lean | 8 +- .../RS/Novel/Skein/IdentityLaw.lean | 6 +- .../RS/Novel/Skein/IdentityLawRight.lean | 6 +- .../RS/Novel/Skein/InterfaceAlternate.lean | 6 +- .../RS/Novel/Skein/InterfaceContract.lean | 6 +- .../RS/Novel/Skein/InterfaceCut.lean | 14 +- .../RS/Novel/Skein/InterfaceOrderIso.lean | 6 +- .../RS/Novel/Skein/InterfaceShift.lean | 6 +- .../RS/Novel/Skein/InvolutionCard.lean | 6 +- .../RS/Novel/Skein/LabelChords.lean | 8 +- .../RS/Novel/Skein/LedgerCast.lean | 6 +- .../RS/Novel/Skein/LedgerRecursion.lean | 8 +- .../RS/Novel/Skein/LedgerSets.lean | 8 +- .../RS/Novel/Skein/LedgerStage.lean | 6 +- .../RS/Novel/Skein/LedgerValue.lean | 8 +- .../RS/Novel/Skein/LoopExample.lean | 6 +- .../RS/Novel/Skein/LoopVerify.lean | 6 +- .../RS/Novel/Skein/MixedPartition.lean | 8 +- .../RS/Novel/Skein/MonoidalInstance.lean | 8 +- .../RS/Novel/Skein/MonoidalNat.lean | 12 +- .../RS/Novel/Skein/MonoidalStruct.lean | 8 +- .../RS/Novel/Skein/Multiplicativity.lean | 6 +- .../RS/Novel/Skein/NonSeparatedStep.lean | 6 +- .../RS/Novel/Skein/OpenCircuits.lean | 6 +- .../RS/Novel/Skein/OrbitParities.lean | 8 +- .../RS/Novel/Skein/OrientExistence.lean | 6 +- .../RS/Novel/Skein/OrientationFlip.lean | 6 +- .../RS/Novel/Skein/PairCloseComm.lean | 6 +- .../RS/Novel/Skein/PairedAssembly.lean | 10 +- .../RS/Novel/Skein/PairingConnectivity.lean | 6 +- .../RS/Novel/Skein/PairingSignature.lean | 6 +- .../RS/Novel/Skein/PairingSwap.lean | 6 +- .../RS/Novel/Skein/PairingValue.lean | 6 +- .../RS/Novel/Skein/PartialClose.lean | 6 +- .../RS/Novel/Skein/PartialCloseCompose.lean | 6 +- .../RS/Novel/Skein/PartialCloseTensor.lean | 6 +- .../RS/Novel/Skein/PathCanon.lean | 8 +- .../RS/Novel/Skein/PathLedger.lean | 8 +- .../RS/Novel/Skein/PathMatch.lean | 6 +- .../RS/Novel/Skein/PermCompose.lean | 10 +- .../RS/Novel/Skein/PermFragment.lean | 6 +- .../RS/Novel/Skein/PropThreeOpen.lean | 8 +- .../RS/Novel/Skein/RSTensor.lean | 14 +- .../RS/Novel/Skein/RelTransition.lean | 6 +- .../RS/Novel/Skein/RelValue.lean | 8 +- .../RS/Novel/Skein/RelabelChords.lean | 8 +- .../RS/Novel/Skein/RelabelInvariance.lean | 6 +- .../RS/Novel/Skein/RepairInvariance.lean | 8 +- .../RS/Novel/Skein/RigidInstance.lean | 6 +- .../RS/Novel/Skein/RigidityClasses.lean | 8 +- .../RS/Novel/Skein/ScalarClass.lean | 8 +- .../RS/Novel/Skein/ScalarFunctional.lean | 6 +- .../RS/Novel/Skein/SeparatedParity.lean | 6 +- .../RS/Novel/Skein/SimpleUnit.lean | 8 +- .../RS/Novel/Skein/SkeinCatInstance.lean | 6 +- .../RS/Novel/Skein/SkeinCategory.lean | 10 +- .../RS/Novel/Skein/SkeinIdeal.lean | 8 +- .../RS/Novel/Skein/SkeinIdealLeft.lean | 8 +- .../RS/Novel/Skein/SkeinLinear.lean | 6 +- .../RS/Novel/Skein/SnakeClasses.lean | 8 +- .../RS/Novel/Skein/StarCompClass.lean | 12 +- .../RS/Novel/Skein/StarDecomposition.lean | 8 +- .../RS/Novel/Skein/StarEnum.lean | 6 +- .../RS/Novel/Skein/StarExplode.lean | 8 +- .../RS/Novel/Skein/StarPrep.lean | 8 +- .../RS/Novel/Skein/StarTrace.lean | 6 +- .../RS/Novel/Skein/StateFlipSet.lean | 6 +- .../RS/Novel/Skein/StatusSet.lean | 8 +- .../RS/Novel/Skein/StepFrame.lean | 8 +- .../RS/Novel/Skein/StepLedger.lean | 10 +- .../RS/Novel/Skein/StepStatus.lean | 6 +- .../RS/Novel/Skein/StepStatusNonsep.lean | 6 +- .../RS/Novel/Skein/StrandBundle.lean | 6 +- .../RS/Novel/Skein/SumLexOrder.lean | 6 +- .../RS/Novel/Skein/SuperGram.lean | 8 +- .../RS/Novel/Skein/SuperSpace.lean | 6 +- .../RS/Novel/Skein/TensorAssoc.lean | 8 +- .../RS/Novel/Skein/TensorComm.lean | 8 +- .../RS/Novel/Skein/TensorCompClass.lean | 10 +- .../RS/Novel/Skein/TensorFragment.lean | 6 +- .../RS/Novel/Skein/TensorIdeal.lean | 10 +- .../RS/Novel/Skein/TensorInterchange.lean | 8 +- .../RS/Novel/Skein/TensorUnit.lean | 6 +- .../RS/Novel/Skein/ThroughEdgeCut.lean | 12 +- .../RS/Novel/Skein/ThroughIndCFalse.lean | 6 +- .../RS/Novel/Skein/ThroughValue.lean | 8 +- .../RegtsSevenster/RS/Novel/Skein/Trace.lean | 8 +- .../RS/Novel/Skein/TraceCyclic.lean | 14 +- .../RS/Novel/Skein/TraceNondegenerate.lean | 8 +- .../RS/Novel/Skein/TransitionExists.lean | 6 +- .../RS/Novel/Skein/TransitionMove.lean | 6 +- .../RS/Novel/Skein/TransposeLedger.lean | 8 +- .../RS/Novel/Skein/TwoPathNonSep.lean | 8 +- .../RS/Novel/Skein/TwoPathStep.lean | 8 +- .../RS/Novel/Skein/VertexOddSign.lean | 8 +- .../RS/Novel/Skein/VertexSum.lean | 6 +- LeanPool/RegtsSevenster/RS/QuantSector.lean | 8 +- .../RegtsSevenster/RS/StatementConverse.lean | 6 +- LeanPool/RegtsSevenster/RS/Summit.lean | 12 +- .../RegtsSevenster/RS/TheoremConverse.lean | 6 +- .../RegtsSevenster/RS/TheoremDimension.lean | 8 +- .../RegtsSevenster/RS/TheoremForward.lean | 8 +- .../RegtsSevenster/RS/TheoremPadding.lean | 8 +- LeanPool/RegtsSevenster/RS/TheoremQuant.lean | 8 +- LeanPool/RegtsSevenster/RS/TheoremTotal.lean | 8 +- LeanPool/RegtsSevenster/Solution.lean | 6 +- 838 files changed, 6788 insertions(+), 3470 deletions(-) diff --git a/LeanPool/RegtsSevenster.lean b/LeanPool/RegtsSevenster.lean index 5a933751dc..02ef97a6f4 100644 --- a/LeanPool/RegtsSevenster.lean +++ b/LeanPool/RegtsSevenster.lean @@ -4,843 +4,845 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS -import LeanPool.RegtsSevenster.RS.Assembly.Blueprint -import LeanPool.RegtsSevenster.RS.Assembly.BlueprintConverse -import LeanPool.RegtsSevenster.RS.Assembly.BlueprintDeligne -import LeanPool.RegtsSevenster.RS.Assembly.BlueprintFactorial -import LeanPool.RegtsSevenster.RS.Assembly.BlueprintSchur -import LeanPool.RegtsSevenster.RS.Assembly.BlueprintStatement -import LeanPool.RegtsSevenster.RS.Classical -import LeanPool.RegtsSevenster.RS.Classical.Algebra.FactorialTrace -import LeanPool.RegtsSevenster.RS.Classical.Algebra.TraceCriterion -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Growth -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Intertwine -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiLinear -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiTrace -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LengthBound -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LinearCategory -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.PartialTrace -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.TensorPow -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Trace -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive -import LeanPool.RegtsSevenster.RS.Classical.Deligne -import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPowAct -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeAdjoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeCoherence -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeFree -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeLinear -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTransport -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeZigzag -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensorUnit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodTransfer -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BlockUnits -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BraidCoherence -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGr -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGraded -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGradedLaws -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBInd -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBNonzero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBofA -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBridge -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainDelta -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.Base -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.FirstSlot -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.SecondSlot -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMul -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulHet -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainNonzero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainShift -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainStage2 -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainUnit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CharSplit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CommonAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoprodPreserve -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescent -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescentClose -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableNullstellensatz -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoverFactor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CycleSplit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayCalculus -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayType -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DeligneAssembly -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DescentClose -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DevissageBound -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledAbelian -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledGrowth -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledLine -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledScalar -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSmall -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSplit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DualityMate -import LeanPool.RegtsSevenster.RS.Classical.Deligne.EvenEmbedMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ExactFromShort -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FactorialBeats -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreBridge -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreEps -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreExact -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFaithful -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFunctor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreLinear -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMix -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMu -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMuNat -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverComplex -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverSplitting -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreRestrict -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreStrong -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FiltNil -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FlatLimit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeCollapseAlg -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeMixRetract -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModAdjoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModFunctor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffleCoh -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormalise -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseBase -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseStep -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowDesc -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowInsert -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSlide -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSummand -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeTwistPi -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaComplex -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaCountable -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairAdd -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeFree -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeMix -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetract -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetractRight -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairUnit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaShift -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaTwistLeft -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GeneratorAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GrowthDichotomy -import LeanPool.RegtsSevenster.RS.Classical.Deligne.HomFinite -import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookMult -import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookZero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdemCut -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdempotentLength -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ImageSubalgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndAllColim -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndBigTensorUnit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCoeq -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCompact -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndDayClosure -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndImage -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndKill -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndLocallyMixed -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfLinear -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndPointTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchurKilled -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSimple -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplitSection -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndUnitNonzero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitState -import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KernelPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaClose -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaData -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KillerNonempty -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KronKill -import LeanPool.RegtsSevenster.RS.Classical.Deligne.LambdaCoend -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixDegenerate -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffleLine -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixSumPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhisker -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhiskerAll -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedConc -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedDiag -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedTransport -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAbelian -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAssoc -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModContractL -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModCross -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModDual -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModIns -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMulti -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMultiTriple -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowCast -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescent -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescentClose -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowStage -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchur -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchurSummand -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModZero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MuInterchange -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MulBy -import LeanPool.RegtsSevenster.RS.Classical.Deligne.NatChain -import LeanPool.RegtsSevenster.RS.Classical.Deligne.NewtonConv -import LeanPool.RegtsSevenster.RS.Classical.Deligne.NullPoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLineMap -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddParity -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddPermSign -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquare -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquareIso -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairCarrier -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairMul -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairPerm -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermNat -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermRepChar -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PlainShuffle -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointBaseChange -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointFibre -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Calculus -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Coherence -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Comparison -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Functor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Residue -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowActMul -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowInduct -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowMerge -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairSucc -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairing -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSucc -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSuccMod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowTriangle -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZig -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZigzag -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PresentedQuotient -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21 -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21Core -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21General -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29Close -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Bridge -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Chain -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Close -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Ind -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Reduce -import LeanPool.RegtsSevenster.RS.Classical.Deligne.RegularSum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoTwist -import LeanPool.RegtsSevenster.RS.Classical.Deligne.RowColIdem -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichMerge -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichZig -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarBraiding -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitEquiv -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitInd -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurTransport -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SeedIns -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeFintype -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SignConj -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleGenerator -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimplePoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleScalars -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleSplit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SmallReduction -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAdjoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAssemble -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitClosure -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitComplement -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitEverything -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExact -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtract -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtractDual -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitMonHom -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitPairDef -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitReduce -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitTransport -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplittingAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.StateTransport -import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepA -import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepATransport -import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepB -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Letters -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Signs -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Standard -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEvenRing -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGamma -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGammaInst -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModAbelian -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprodMap -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModIso -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShift -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShiftUnit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperPointMod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperRealize -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSeries -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSmall -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperValues -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperVectSchur -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorPowZero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorTransfer -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorZigzag -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TrichotomyClose -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistCoherence -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistFreeTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistMixLine -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistShuffle -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistState -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistSymPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistUnitor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitBase -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitFreeMod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitMod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitStage -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UniversalAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.WhiskerFaithful -import LeanPool.RegtsSevenster.RS.Classical.Deligne.WordMap -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZagAction -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagNonzero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagSandwich -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransfer -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransferIso -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneBridge -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackageRestrict -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneTheorem -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.FibreTransport -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.KoszulAction -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaPerm -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaTensorPower -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorDischarge -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorIntertwine -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.TotalDimension -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BlockKill -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BranchTrace -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CentralElem -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharClass -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharDecomp -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharEquiv -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourCycleSum -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CommutantBound -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ContentCount -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleFactor -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSum -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSumPrep -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.EndSum -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FibreCard -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FixWeight -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.HVal -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.IdempotentBridge -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTChar -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIntChar -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIrreducible -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTOrtho -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTPad -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTSimple -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.KillSimples -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedCount -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedFixed -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeAction -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.OrbitBridge -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.Package -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairChar -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairInner -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairOrbit -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairStab -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairTuple -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairingPos -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PermModule -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.RegularTrace -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SameCycleQuot -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ScalarTrace -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SchurAction -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SigmaCycleType -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignResolve -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignedTensor -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SimpleEmbed -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowth -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowthSharp -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareStair -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.StabCount -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorNonvanishing -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorTrace -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.WordCommutant -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourAction -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConj -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjStep -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjTop -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourEval -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourExtendSwap -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourFormMatch -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMerge -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMergeOdd -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairing -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairingSymm -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourTotal -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord -import LeanPool.RegtsSevenster.RS.Classical.Super.OrthonormalBasis -import LeanPool.RegtsSevenster.RS.Classical.Super.PowBraid -import LeanPool.RegtsSevenster.RS.Classical.Super.SuperVect -import LeanPool.RegtsSevenster.RS.Classical.Super.SymplecticBasis -import LeanPool.RegtsSevenster.RS.Classical.Super.TotalSpace -import LeanPool.RegtsSevenster.RS.Classical.Super.WordSignPerm -import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantExpand -import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantPieri -import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantStrict -import LeanPool.RegtsSevenster.RS.Classical.SymFun.Bialternant -import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialDet -import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialH -import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffExtract -import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffSplit -import LeanPool.RegtsSevenster.RS.Classical.SymFun.DeltaSeq -import LeanPool.RegtsSevenster.RS.Classical.SymFun.DescVandermonde -import LeanPool.RegtsSevenster.RS.Classical.SymFun.DimFormula -import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHConv -import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHDischarge -import LeanPool.RegtsSevenster.RS.Classical.SymFun.HInsert -import LeanPool.RegtsSevenster.RS.Classical.SymFun.HProdCoeff -import LeanPool.RegtsSevenster.RS.Classical.SymFun.HSubZ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.HookVanishing -import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTDetExpand -import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTGuard -import LeanPool.RegtsSevenster.RS.Classical.SymFun.LGVStrict -import LeanPool.RegtsSevenster.RS.Classical.SymFun.PieriChain -import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowCount -import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums -import LeanPool.RegtsSevenster.RS.Classical.SymFun.RationalityFromRecurrence -import LeanPool.RegtsSevenster.RS.Classical.SymFun.RecurrenceFromVanishing -import LeanPool.RegtsSevenster.RS.Classical.SymFun.SubsetEH -import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums -import LeanPool.RegtsSevenster.RS.Classical.SymFun.TCount -import LeanPool.RegtsSevenster.RS.Classical.SymFun.TIdentity -import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaExp -import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaRational -import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaSeries -import LeanPool.RegtsSevenster.RS.Common -import LeanPool.RegtsSevenster.RS.Common.DiagramChain -import LeanPool.RegtsSevenster.RS.Common.ExponentialGrowth -import LeanPool.RegtsSevenster.RS.Common.FactorialBound -import LeanPool.RegtsSevenster.RS.Common.FinSlots -import LeanPool.RegtsSevenster.RS.Common.ListAttach -import LeanPool.RegtsSevenster.RS.Common.ListPairs -import LeanPool.RegtsSevenster.RS.Common.ListSign -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps -import LeanPool.RegtsSevenster.RS.Common.NilpotentMap -import LeanPool.RegtsSevenster.RS.Common.NilpotentPowerTrace -import LeanPool.RegtsSevenster.RS.Common.PairDisjoint -import LeanPool.RegtsSevenster.RS.Common.PermCongr -import LeanPool.RegtsSevenster.RS.Common.PermTopSplit -import LeanPool.RegtsSevenster.RS.Common.ProdSum -import LeanPool.RegtsSevenster.RS.Common.RowLenChain -import LeanPool.RegtsSevenster.RS.Common.RowSpanRank -import LeanPool.RegtsSevenster.RS.Common.TraceSeparation -import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams -import LeanPool.RegtsSevenster.RS.Definitions -import LeanPool.RegtsSevenster.RS.DimensionDefinitions -import LeanPool.RegtsSevenster.RS.Glossary -import LeanPool.RegtsSevenster.RS.Novel -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjSwapBmc -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjacentWord -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisCoord -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisSplit -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaData -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiag -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiagForm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaFlip -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockCanon -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockOddList -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockParity -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockRestrict -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSigma -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSort -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BraidWord -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonColour -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapClosed -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapExpansion -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapFun -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapMatch -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeel -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeelSplit -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapSplit -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapVal -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ChainLists -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleModel -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleScalar -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircuitCount -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ClosedTransition -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ConcatSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordInterface -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordOf -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoreParity -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EdgeSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvForm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvFormOdd -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvLeaf -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FibreParam -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FlagEnum -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.GlobalSlotList -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.HRS -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ListSignPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MasterSum -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelCoord -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelStarVec -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MultiStar -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFDef -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFValue -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddFlip -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddListMultiset -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddPair -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddSignProd -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaCotensor -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTensor -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTransport -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OneBasis -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OrbitCard -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OutSignEdges -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairEnum -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairList -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ParameterModel -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PatternInv -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RegroupSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.Reindex -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexHeart -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexVanish -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RiffleSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SignPair -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SkeinPowBraid -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SlotPairing -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortFactor -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarClassFactor -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPeel -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarRepeat -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarSymm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarTensorClass -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StdTransport -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StrandTransport -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauCount -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TopBraidMerge -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TwoBasis -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue -import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomDichotomy -import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomicIdempotents -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockAssembly -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockBounds -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockCycle -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactor -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactorialTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockSplice -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockTower -import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleNormal -import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvAbelian -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDeligne -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDelignePackage -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGenerator -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGrowth -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvSemisimple -import LeanPool.RegtsSevenster.RS.Novel.Envelope.FactorialTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.Frobenius -import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement -import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinementSharp -import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiEmbBraided -import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiMonoidal -import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiRigid -import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiSemisimple -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatBraided -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatEmbMonoidal -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatMonoidal -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatRigid -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatSemisimple -import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentMatTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.ObjectTower -import LeanPool.RegtsSevenster.RS.Novel.Envelope.PermTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.RankDimension -import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarPermTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleAll -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleEnd -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinDimBound -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SuperKill -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast -import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowHom -import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowSplit -import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZeta -import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZetaSharp -import LeanPool.RegtsSevenster.RS.Novel.Extraction.CircleValue -import LeanPool.RegtsSevenster.RS.Novel.Extraction.CoordIso -import LeanPool.RegtsSevenster.RS.Novel.Extraction.Coordinates -import LeanPool.RegtsSevenster.RS.Novel.Extraction.CopairUnique -import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate -import LeanPool.RegtsSevenster.RS.Novel.Extraction.SnakeTransport -import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdDuality -import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid -import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper -import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalAgreement -import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalIndependence -import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedNat -import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleClose -import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleMapClasses -import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleTensor -import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence -import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonTransport -import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonicalFrame -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChainAgreement -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordCount -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordParity -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordSwapParity -import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate -import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotateLeft -import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseUnion -import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedAgreement -import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedCutDispatch -import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedIdentify -import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedTopSum -import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourEmbedding -import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourGlue -import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourPadding -import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourRecursion -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeNormal -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeRelabel -import LeanPool.RegtsSevenster.RS.Novel.Skein.Composition -import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseAssembly -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseFamily -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseGram -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseIdentity -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseLift -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConversePair -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseTrip -import LeanPool.RegtsSevenster.RS.Novel.Skein.CrossingDelta -import LeanPool.RegtsSevenster.RS.Novel.Skein.CutMatching -import LeanPool.RegtsSevenster.RS.Novel.Skein.CutSubsetSum -import LeanPool.RegtsSevenster.RS.Novel.Skein.DirMatching -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjSubsetSplit -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.A -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.B -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.C -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionProduct -import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeColouring -import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeSum -import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeTerm -import LeanPool.RegtsSevenster.RS.Novel.Skein.Eulerian -import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.FibreValue -import LeanPool.RegtsSevenster.RS.Novel.Skein.FlagGraph -import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignForm -import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignProduct -import LeanPool.RegtsSevenster.RS.Novel.Skein.FourLabelParity -import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv -import LeanPool.RegtsSevenster.RS.Novel.Skein.GenBoundaryStates -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueAmbient -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChord -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChords -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCircuitDelta -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueComm -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueLedger -import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueRelTransport -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplit -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.A -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.C -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSubsetBij -import LeanPool.RegtsSevenster.RS.Novel.Skein.GramRank -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomCompose -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomSpaces -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceCyclic -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate -import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw -import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceAlternate -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceContract -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceCut -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceOrderIso -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceShift -import LeanPool.RegtsSevenster.RS.Novel.Skein.InvolutionCard -import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords -import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerCast -import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerRecursion -import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerSets -import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerStage -import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerValue -import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopExample -import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopVerify -import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition -import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalNat -import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalStruct -import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity -import LeanPool.RegtsSevenster.RS.Novel.Skein.NonSeparatedStep -import LeanPool.RegtsSevenster.RS.Novel.Skein.OpenCircuits -import LeanPool.RegtsSevenster.RS.Novel.Skein.OrbitParities -import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientExistence -import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientationFlip -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairCloseComm -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairedAssembly -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSwap -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingValue -import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialClose -import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseCompose -import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseTensor -import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon -import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger -import LeanPool.RegtsSevenster.RS.Novel.Skein.PathMatch -import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose -import LeanPool.RegtsSevenster.RS.Novel.Skein.PermFragment -import LeanPool.RegtsSevenster.RS.Novel.Skein.PropThreeOpen -import LeanPool.RegtsSevenster.RS.Novel.Skein.RSTensor -import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition -import LeanPool.RegtsSevenster.RS.Novel.Skein.RelValue -import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelChords -import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelInvariance -import LeanPool.RegtsSevenster.RS.Novel.Skein.RepairInvariance -import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidityClasses -import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarClass -import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarFunctional -import LeanPool.RegtsSevenster.RS.Novel.Skein.SeparatedParity -import LeanPool.RegtsSevenster.RS.Novel.Skein.SimpleUnit -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCategory -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdealLeft -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinLinear -import LeanPool.RegtsSevenster.RS.Novel.Skein.SnakeClasses -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarCompClass -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarDecomposition -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarEnum -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarExplode -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarPrep -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarTrace -import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet -import LeanPool.RegtsSevenster.RS.Novel.Skein.StatusSet -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepFrame -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatus -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatusNonsep -import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle -import LeanPool.RegtsSevenster.RS.Novel.Skein.SumLexOrder -import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperGram -import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperSpace -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorAssoc -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorComm -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorCompClass -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorInterchange -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorUnit -import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut -import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughIndCFalse -import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue -import LeanPool.RegtsSevenster.RS.Novel.Skein.Trace -import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic -import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceNondegenerate -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionMove -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger -import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathNonSep -import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathStep -import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexOddSign -import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexSum -import LeanPool.RegtsSevenster.RS.QuantSector -import LeanPool.RegtsSevenster.RS.StatementConverse -import LeanPool.RegtsSevenster.RS.Summit -import LeanPool.RegtsSevenster.RS.TheoremConverse -import LeanPool.RegtsSevenster.RS.TheoremDimension -import LeanPool.RegtsSevenster.RS.TheoremForward -import LeanPool.RegtsSevenster.RS.TheoremPadding -import LeanPool.RegtsSevenster.RS.TheoremQuant -import LeanPool.RegtsSevenster.RS.TheoremTotal -import LeanPool.RegtsSevenster.Solution +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 diff --git a/LeanPool/RegtsSevenster/RS.lean b/LeanPool/RegtsSevenster/RS.lean index 00f2b0e6d9..ef26b01c71 100644 --- a/LeanPool/RegtsSevenster/RS.lean +++ b/LeanPool/RegtsSevenster/RS.lean @@ -4,25 +4,27 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common -import LeanPool.RegtsSevenster.RS.Classical -import LeanPool.RegtsSevenster.RS.Novel -import LeanPool.RegtsSevenster.RS.Definitions -import LeanPool.RegtsSevenster.RS.StatementConverse -import LeanPool.RegtsSevenster.RS.TheoremForward -import LeanPool.RegtsSevenster.RS.TheoremQuant -import LeanPool.RegtsSevenster.RS.TheoremTotal -import LeanPool.RegtsSevenster.RS.TheoremConverse -import LeanPool.RegtsSevenster.RS.QuantSector -import LeanPool.RegtsSevenster.RS.Glossary -import LeanPool.RegtsSevenster.RS.Assembly.BlueprintStatement -import LeanPool.RegtsSevenster.RS.Assembly.Blueprint -import LeanPool.RegtsSevenster.RS.Assembly.BlueprintConverse -import LeanPool.RegtsSevenster.RS.Assembly.BlueprintSchur -import LeanPool.RegtsSevenster.RS.Classical.Deligne -import LeanPool.RegtsSevenster.RS.Summit -import LeanPool.RegtsSevenster.RS.Assembly.BlueprintDeligne -import LeanPool.RegtsSevenster.RS.Assembly.BlueprintFactorial -import LeanPool.RegtsSevenster.RS.DimensionDefinitions -import LeanPool.RegtsSevenster.RS.TheoremDimension -import LeanPool.RegtsSevenster.RS.TheoremPadding +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 index 6528be520d..796fb31b3f 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean @@ -4,245 +4,247 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps -import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams -import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourCycleSum -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTOrtho -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignResolve -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowth -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BranchTrace -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTPad -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.Package -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairingPos -import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZeta -import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaExp -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowthSharp -import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinementSharp -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinDimBound -import LeanPool.RegtsSevenster.RS.Novel.Skein.PathMatch -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SuperKill -import LeanPool.RegtsSevenster.RS.StatementConverse -import LeanPool.RegtsSevenster.RS.TheoremQuant -import LeanPool.RegtsSevenster.RS.Classical.SymFun.LGVStrict -import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedAgreement -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionMove -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueRelTransport -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjSubsetSplit -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceOrderIso -import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue -import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelInvariance -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCircuitDelta -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChainAgreement -import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence -import LeanPool.RegtsSevenster.RS.Novel.Skein.RepairInvariance -import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordParity -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger -import LeanPool.RegtsSevenster.RS.Novel.Skein.InvolutionCard -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordCount -import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalIndependence -import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalAgreement -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseAssembly -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceAlternate -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseGram -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger -import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathNonSep -import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonicalFrame -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepFrame -import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet -import LeanPool.RegtsSevenster.RS.Novel.Skein.StatusSet -import LeanPool.RegtsSevenster.RS.Novel.Skein.CrossingDelta -import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignProduct -import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignForm -import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerSets -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatus -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatusNonsep -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairedAssembly -import LeanPool.RegtsSevenster.RS.Novel.Skein.PropThreeOpen -import LeanPool.RegtsSevenster.RS.Novel.Skein.FourLabelParity -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSwap -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingValue -import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerValue -import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopVerify -import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughIndCFalse -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels -import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords -import LeanPool.RegtsSevenster.RS.Novel.Skein.FibreValue -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChords -import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta -import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedCutDispatch -import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut -import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelChords -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordSwapParity -import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums -import LeanPool.RegtsSevenster.RS.Classical.SymFun.RecurrenceFromVanishing -import LeanPool.RegtsSevenster.RS.Classical.SymFun.RationalityFromRecurrence -import LeanPool.RegtsSevenster.RS.Classical.SymFun.HookVanishing -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockBounds -import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement -import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiMonoidal -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatMonoidal -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatBraided -import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleEnd -import LeanPool.RegtsSevenster.RS.Classical.Super.OrthonormalBasis -import LeanPool.RegtsSevenster.RS.Classical.Super.SuperVect -import LeanPool.RegtsSevenster.RS.Classical.Super.SymplecticBasis -import LeanPool.RegtsSevenster.RS.Novel.Skein.FlagGraph -import LeanPool.RegtsSevenster.RS.Novel.Skein.Composition -import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv -import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv -import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle -import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw -import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomSpaces -import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity -import LeanPool.RegtsSevenster.RS.Novel.Skein.Eulerian -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueAmbient -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueComm -import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate -import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotateLeft -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceShift -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairCloseComm -import LeanPool.RegtsSevenster.RS.Novel.Skein.SimpleUnit -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdealLeft -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomCompose -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCategory -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinLinear -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceCyclic -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarDecomposition -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeNormal -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold -import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition -import LeanPool.RegtsSevenster.RS.Novel.Skein.PermFragment -import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose -import LeanPool.RegtsSevenster.RS.Novel.Skein.Trace -import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic -import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceNondegenerate -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorComm -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorAssoc -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorUnit -import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseTensor -import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseUnion -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeRelabel -import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseCompose -import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarClass -import LeanPool.RegtsSevenster.RS.Definitions -import LeanPool.RegtsSevenster.RS.Novel.Extraction.CircleValue -import LeanPool.RegtsSevenster.RS.Novel.Extraction.CoordIso -import LeanPool.RegtsSevenster.RS.Novel.Extraction.Coordinates -import LeanPool.RegtsSevenster.RS.Novel.Extraction.CopairUnique -import LeanPool.RegtsSevenster.RS.Novel.Extraction.SnakeTransport -import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate -import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdDuality -import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid -import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneBridge -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneTheorem -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.FibreTransport -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarTrace -import LeanPool.RegtsSevenster.RS.Novel.Skein.SnakeClasses -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourFormMatch -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairing -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairingSymm -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorInterchange -import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarCompClass -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTransport -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortFactor -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarClassFactor -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTensor -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleModel -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BraidWord -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarSymm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelStarVec -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ParameterModel -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjStep -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord -import LeanPool.RegtsSevenster.RS.Classical.Super.WordSignPerm -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjTop -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourAction -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapClosed -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MasterSum -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarRepeat -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.Reindex -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FibreParam -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockParity -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexVanish -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiagForm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaData -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddFlip -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PatternInv -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ListSignPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OutSignEdges -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EdgeSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddListMultiset -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddSignProd -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaFlip -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircuitCount -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairEnum -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FlagEnum -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockCanon -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockOddList -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauCount -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.GlobalSlotList -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ChainLists -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ConcatSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SignPair -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RiffleSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFDef -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RegroupSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoreParity -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFValue -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexHeart -import LeanPool.RegtsSevenster.RS.TheoremForward -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapVal -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapSplit -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ClosedTransition -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelCoord -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OneBasis -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvLeaf -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapExpansion -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeelSplit -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisCoord -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiag -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SlotPairing -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TopBraidMerge -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TwoBasis -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDelignePackage +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 diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintConverse.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintConverse.lean index 339f2e01bd..29b7cc7571 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintConverse.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintConverse.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Assembly.BlueprintSchur -import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopExample -import LeanPool.RegtsSevenster.RS.TheoremConverse +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 diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintDeligne.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintDeligne.lean index 5597ff341f..b98ff5b7ad 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintDeligne.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintDeligne.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Summit +module + +public import LeanPool.RegtsSevenster.RS.Summit /-! # Audit: Deligne's theorem and the unconditional summit @@ -16,6 +18,8 @@ depend on nothing beyond `propext`, `Classical.choice` and `Quot.sound` is checked rather than asserted. -/ +@[expose] public section + namespace RS /-! ### Deligne's theorem -/ diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintFactorial.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintFactorial.lean index b6dab7fbd6..969aae591d 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintFactorial.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintFactorial.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.FactorialTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiSemisimple -import LeanPool.RegtsSevenster.RS.Novel.Envelope.ObjectTower -import LeanPool.RegtsSevenster.RS.Summit +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 @@ -27,6 +29,8 @@ trace-zeta mechanisms. Schur theory used by Deligne and by the colour bounds is audited separately. -/ +@[expose] public section + namespace RS /-! ### Statements -/ diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean index c81c7d75cc..6f2eaa7c60 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Assembly.Blueprint -import LeanPool.RegtsSevenster.RS.Novel.Envelope.ObjectTower -import LeanPool.RegtsSevenster.RS.TheoremTotal +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 diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean index c0311de6c3..c85141633a 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean @@ -4,11 +4,13 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopExample -import LeanPool.RegtsSevenster.RS.TheoremConverse -import LeanPool.RegtsSevenster.RS.TheoremForward -import LeanPool.RegtsSevenster.RS.TheoremQuant -import LeanPool.RegtsSevenster.RS.Summit +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 @@ -42,6 +44,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical.lean b/LeanPool/RegtsSevenster/RS/Classical.lean index 69be3a4149..696dd9af51 100644 --- a/LeanPool/RegtsSevenster/RS/Classical.lean +++ b/LeanPool/RegtsSevenster/RS/Classical.lean @@ -4,140 +4,142 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Algebra.TraceCriterion -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiLinear -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiTrace -import LeanPool.RegtsSevenster.RS.Classical.Algebra.FactorialTrace -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Growth -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Intertwine -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LengthBound -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LinearCategory -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.PartialTrace -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.TensorPow -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Trace -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneBridge -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackageRestrict -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneTheorem -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.FibreTransport -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.KoszulAction -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaPerm -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaTensorPower -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorDischarge -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorIntertwine -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.TotalDimension -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BlockKill -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BranchTrace -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CentralElem -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharClass -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharDecomp -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharEquiv -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourCycleSum -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CommutantBound -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ContentCount -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleFactor -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSum -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSumPrep -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.EndSum -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FibreCard -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FixWeight -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.HVal -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.IdempotentBridge -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTChar -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIntChar -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIrreducible -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTOrtho -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTPad -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTSimple -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.KillSimples -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedCount -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedFixed -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeAction -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.OrbitBridge -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.Package -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairChar -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairInner -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairOrbit -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairStab -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairTuple -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairingPos -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PermModule -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.RegularTrace -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SameCycleQuot -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ScalarTrace -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SchurAction -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SigmaCycleType -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignResolve -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignedTensor -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SimpleEmbed -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowth -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowthSharp -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareStair -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.StabCount -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorNonvanishing -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorTrace -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.WordCommutant -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourAction -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConj -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjStep -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjTop -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourEval -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourExtendSwap -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourFormMatch -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMerge -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMergeOdd -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairing -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairingSymm -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourTotal -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord -import LeanPool.RegtsSevenster.RS.Classical.Super.OrthonormalBasis -import LeanPool.RegtsSevenster.RS.Classical.Super.PowBraid -import LeanPool.RegtsSevenster.RS.Classical.Super.SuperVect -import LeanPool.RegtsSevenster.RS.Classical.Super.SymplecticBasis -import LeanPool.RegtsSevenster.RS.Classical.Super.TotalSpace -import LeanPool.RegtsSevenster.RS.Classical.Super.WordSignPerm -import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantExpand -import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantPieri -import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantStrict -import LeanPool.RegtsSevenster.RS.Classical.SymFun.Bialternant -import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialDet -import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialH -import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffExtract -import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffSplit -import LeanPool.RegtsSevenster.RS.Classical.SymFun.DeltaSeq -import LeanPool.RegtsSevenster.RS.Classical.SymFun.DescVandermonde -import LeanPool.RegtsSevenster.RS.Classical.SymFun.DimFormula -import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHConv -import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHDischarge -import LeanPool.RegtsSevenster.RS.Classical.SymFun.HInsert -import LeanPool.RegtsSevenster.RS.Classical.SymFun.HProdCoeff -import LeanPool.RegtsSevenster.RS.Classical.SymFun.HSubZ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.HookVanishing -import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTDetExpand -import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTGuard -import LeanPool.RegtsSevenster.RS.Classical.SymFun.LGVStrict -import LeanPool.RegtsSevenster.RS.Classical.SymFun.PieriChain -import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowCount -import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums -import LeanPool.RegtsSevenster.RS.Classical.SymFun.RationalityFromRecurrence -import LeanPool.RegtsSevenster.RS.Classical.SymFun.RecurrenceFromVanishing -import LeanPool.RegtsSevenster.RS.Classical.SymFun.SubsetEH -import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums -import LeanPool.RegtsSevenster.RS.Classical.SymFun.TCount -import LeanPool.RegtsSevenster.RS.Classical.SymFun.TIdentity -import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaExp -import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaRational -import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaSeries -import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid -import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper +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 index 75e1dddd88..daafb8a102 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Algebra/FactorialTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Algebra/FactorialTrace.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.NilpotentPowerTrace -import LeanPool.RegtsSevenster.RS.Common.TraceSeparation -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FactorialBeats +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 @@ -23,6 +25,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Algebra/TraceCriterion.lean b/LeanPool/RegtsSevenster/RS/Classical/Algebra/TraceCriterion.lean index 2730bf22d6..7e6e6445aa 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Algebra/TraceCriterion.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Algebra/TraceCriterion.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Semisimplicity from a trace form @@ -18,6 +20,8 @@ forcing `j = 0`. -/ +@[expose] public section + namespace RS universe u diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Growth.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Growth.lean index 628f72c905..d69972d693 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Growth.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Growth.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LengthBound +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LengthBound /-! # Moderate growth of tensor powers @@ -22,6 +24,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Intertwine.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Intertwine.lean index 6e849765dc..2c499c5c4f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Intertwine.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Intertwine.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Linear combinations of intertwining endomorphisms @@ -13,6 +15,8 @@ An intertwining relation is preserved by addition and scalar multiplication in a linear category. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiLinear.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiLinear.lean index dc4c03f9d2..b50595b3c8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiLinear.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiLinear.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Linear structure on a Karoubi completion @@ -13,6 +15,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiTrace.lean index e3563a40fd..491190d52f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/KaroubiTrace.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiLinear -import LeanPool.RegtsSevenster.RS.Classical.Algebra.TraceCriterion -import LeanPool.RegtsSevenster.RS.Common.NilpotentMap +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 @@ -17,6 +19,8 @@ nondegenerate trace that kills nilpotents proves semisimplicity of every corner endomorphism algebra. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.Idempotents diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Length.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Length.lean index 4b7bccdfbe..abdf787f6e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Length.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Length.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Definitions +module + +public import LeanPool.RegtsSevenster.RS.Definitions /-! # Bounded length for objects of an abelian category @@ -23,6 +25,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LengthBound.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LengthBound.lean index 63f866ddd8..a0f9077ac4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LengthBound.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LengthBound.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LinearCategory +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LinearCategory /-! # Length bounded by the endomorphism dimension @@ -21,6 +23,8 @@ in `End Y`, hence a linearly independent family, so that two halves. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LinearCategory.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LinearCategory.lean index cb9c00f905..c346bef0aa 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LinearCategory.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/LinearCategory.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Definitions +module + +public import LeanPool.RegtsSevenster.RS.Definitions /-! # Conditions on a ℂ-linear category @@ -16,6 +18,8 @@ scalar endomorphisms of the tensor unit (`HasScalarUnit`), is defined in `RS/Definitions.lean`. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.Limits MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/PartialTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/PartialTrace.lean index d688c6599f..fd2c0b52dc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/PartialTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/PartialTrace.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Trace +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Trace /-! # The partial categorical trace @@ -21,6 +23,8 @@ trace. Those are what the cycle-trace factorisation of a permutation action needs. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.Category CategoryTheory.MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/TensorPow.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/TensorPow.lean index 3a570ded2a..25ddd38095 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/TensorPow.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/TensorPow.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length /-! # Tensor powers of an object @@ -17,6 +19,8 @@ satisfies, and the implication from it to Deligne's subquotient form. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.Limits MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Trace.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Trace.lean index 5139c08794..00c6572703 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Trace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/Trace.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd /-! # The categorical trace @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/UnitEnd.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/UnitEnd.lean index b4d175bfc3..3d7af0c0ce 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/UnitEnd.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/UnitEnd.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # The scalars of a monoidal category commute @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/WhiskerAdditive.lean b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/WhiskerAdditive.lean index f0ad6d889e..814cc1706a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/CatTheory/WhiskerAdditive.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/CatTheory/WhiskerAdditive.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Whiskering against negation, zero and binary biproducts @@ -25,6 +27,8 @@ instance for `tensorLeft`, so the distributors are built here directly. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne.lean index 3b2f88b014..067a716be8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne.lean @@ -4,333 +4,335 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPowAct -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeAdjoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeCoherence -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeFree -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeLinear -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTransport -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeZigzag -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensorUnit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodTransfer -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BlockUnits -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BraidCoherence -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGr -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGraded -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGradedLaws -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBInd -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBNonzero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBofA -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBridge -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainDelta -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.Base -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.FirstSlot -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.SecondSlot -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMul -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulHet -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainNonzero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainShift -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainStage2 -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainUnit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CharSplit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CommonAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoprodPreserve -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescent -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescentClose -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableNullstellensatz -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoverFactor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CycleSplit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayCalculus -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayType -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DeligneAssembly -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DescentClose -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DevissageBound -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledAbelian -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledGrowth -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledLine -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledScalar -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSmall -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSplit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DualityMate -import LeanPool.RegtsSevenster.RS.Classical.Deligne.EvenEmbedMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ExactFromShort -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FactorialBeats -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreBridge -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreEps -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreExact -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFaithful -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFunctor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMix -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMu -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreLinear -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMuNat -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverComplex -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverSplitting -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreRestrict -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreStrong -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FiltNil -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FlatLimit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeCollapseAlg -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeMixRetract -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModAdjoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModFunctor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffleCoh -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSummand -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormalise -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseBase -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseStep -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowDesc -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowInsert -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSlide -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeTwistPi -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaCountable -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaComplex -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairAdd -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeFree -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeMix -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetract -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetractRight -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairUnit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaShift -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaTwistLeft -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GeneratorAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GrowthDichotomy -import LeanPool.RegtsSevenster.RS.Classical.Deligne.HomFinite -import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookMult -import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookZero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdemCut -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdempotentLength -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ImageSubalgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndAllColim -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndBigTensorUnit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCoeq -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCompact -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndDayClosure -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndImage -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndKill -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndLocallyMixed -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfLinear -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndPointTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchurKilled -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSimple -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplitSection -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndUnitNonzero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitState -import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KernelPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaClose -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaData -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KillerNonempty -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KronKill -import LeanPool.RegtsSevenster.RS.Classical.Deligne.LambdaCoend -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixDegenerate -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffleLine -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixSumPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhisker -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhiskerAll -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedConc -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedDiag -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedTransport -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAssoc -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAbelian -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModContractL -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModCross -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModDual -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModIns -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMulti -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMultiTriple -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowCast -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescent -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescentClose -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowStage -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchur -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchurSummand -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModZero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MulBy -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MuInterchange -import LeanPool.RegtsSevenster.RS.Classical.Deligne.NatChain -import LeanPool.RegtsSevenster.RS.Classical.Deligne.NewtonConv -import LeanPool.RegtsSevenster.RS.Classical.Deligne.NullPoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLineMap -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddParity -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddPermSign -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquare -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquareIso -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairCarrier -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairMul -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairPerm -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermNat -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermRepChar -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PlainShuffle -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointBaseChange -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointFibre -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Calculus -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Coherence -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Comparison -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Functor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Residue -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowActMul -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowInduct -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowMerge -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairSucc -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairing -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSucc -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSuccMod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowTriangle -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZig -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZigzag -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PresentedQuotient -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21 -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21Core -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21General -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29Close -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Bridge -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Chain -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Close -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Ind -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Reduce -import LeanPool.RegtsSevenster.RS.Classical.Deligne.RegularSum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoTwist -import LeanPool.RegtsSevenster.RS.Classical.Deligne.RowColIdem -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichMerge -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichZig -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarBraiding -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitEquiv -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitInd -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurTransport -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SeedIns -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeFintype -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SignConj -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleGenerator -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SmallReduction -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleSplit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimplePoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleScalars -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAdjoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitClosure -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitEverything -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAssemble -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitComplement -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExact -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtract -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtractDual -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitMonHom -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitPairDef -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitReduce -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitTransport -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplittingAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.StateTransport -import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepA -import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepATransport -import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepB -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Letters -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Signs -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Standard -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEvenRing -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGamma -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGammaInst -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModAbelian -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprodMap -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModIso -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShift -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShiftUnit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperPointMod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperRealize -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSeries -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSmall -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperValues -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperVectSchur -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorPowZero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorTransfer -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorZigzag -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TrichotomyClose -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistCoherence -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistFreeTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistMixLine -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistShuffle -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistState -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistSymPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistUnitor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitBase -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitFreeMod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitMod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitStage -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UniversalAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.WhiskerFaithful -import LeanPool.RegtsSevenster.RS.Classical.Deligne.WordMap -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZagAction -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagNonzero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagSandwich -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransfer -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransferIso +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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPow.lean index 33c5b708f1..5cec8142f8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPow.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPow.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg /-! # Alternating powers over an internal monoid @@ -32,6 +34,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPowAct.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPowAct.lean index afe1533625..c80aff19eb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPowAct.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/AltPowAct.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct /-! # The monoid action on alternating powers @@ -29,6 +31,8 @@ every positive alternating power a module. * `altPowMod`: the bundled module. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean index ca5343df51..7c4841849b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTransport -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtractDual +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTransport +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtractDual /-! # The base-changed pairing on its cover @@ -17,6 +19,8 @@ the base morphism. This is the working form for the adjointness of the split idempotents. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeBiprod.lean index d15620018a..993624d297 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeBiprod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeBiprod.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod /-! # Base change distributes over biproducts @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean index 02bc74dfa6..7436bfa8bc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract /-! # Coherence of the base-change structure map @@ -15,6 +17,8 @@ collapse: contracting the regular factor before or after the base change gives the same map. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeDatum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeDatum.lean index 6933f971e1..ea5e4cfea0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeDatum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeDatum.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeLinear -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeLinear +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle /-! # The base change of a duality datum @@ -17,6 +19,8 @@ composites defining the base-changed pairing and copairing are linear too. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeFree.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeFree.lean index b0e58527ed..aa70d63a91 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeFree.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeFree.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor /-! # Base change of a free module @@ -20,6 +22,8 @@ the free module on an object to the free module over the new base: A V) ≅ freeMod B V` in the category of `B`-modules. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeLinear.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeLinear.lean index ef52bf49de..b5b8926d22 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeLinear.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeLinear.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeBiprod +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 @@ -16,6 +18,8 @@ intertwines the descended actions, and the two linearity laws follow by chaining the factors. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeMonoidal.lean index 0898b1c252..614698d446 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeMonoidal.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeCoherence -import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepATransport +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeCoherence +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepATransport /-! # Base change as a monoidal functor @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTensor.lean index 9c9788de1a..6fdd78b4f2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTensor.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAssoc -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma +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 @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTransport.lean index 8c22af3966..5261657092 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeTransport.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeZigzag -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagSandwich +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 @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeZigzag.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeZigzag.lean index 384e8aa6b4..89e223a222 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeZigzag.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeZigzag.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum /-! # The zigzag laws of a base-changed duality datum @@ -13,6 +15,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensor.lean index d917a5526d..afb1fde45f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensor.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # The tensor product of an arbitrary family of monoid objects @@ -24,6 +26,8 @@ transition maps of a `Finset ι`-shaped diagram, and the big tensor product is its colimit. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensorUnit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensorUnit.lean index a52836b80e..21ca80ca04 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensorUnit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BigTensorUnit.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensor +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensor /-! # The unit of a big tensor product survives @@ -18,6 +20,8 @@ ambient category can be tested against the filtered colimit one stage at a time. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodPow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodPow.lean index 6bef4df0ed..21a5a75a71 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodPow.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodPow.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedConc -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermNat +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 @@ -34,6 +36,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodTransfer.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodTransfer.lean index 2f8a7f0512..b41f9827f4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodTransfer.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BiprodTransfer.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndKill -import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookMult +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 @@ -22,6 +24,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BlockUnits.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BlockUnits.lean index 3e983b84da..f3558f5f6d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BlockUnits.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BlockUnits.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage /-! # Matrix units inside a block @@ -27,6 +29,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BraidCoherence.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BraidCoherence.lean index 90718afb61..3d2fb59c4b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BraidCoherence.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BraidCoherence.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid /-! # A braid-coherence identity for the interchange prefix @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainAlgebra.lean index 87d9b0316b..c97cc38830 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainAlgebra.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainAlgebra.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainUnit +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainUnit /-! # The colimit algebra of the splitting chain @@ -28,6 +30,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainB.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainB.lean index c9c6ff7351..bb40feada6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainB.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainB.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainDelta +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 @@ -17,6 +19,8 @@ insertion is inserting after multiplying. These are the compatibility squares consumed by the colimit algebra. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean index bf3828c17d..e44cfdd595 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGradedLaws +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGradedLaws /-! # The graded splitting algebra carrier @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean index b0800c0365..d6aebf67fe 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulHet -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainShift +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 @@ -19,6 +21,8 @@ algebra. The balanced line recovers the degree-zero algebra carrier. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGradedLaws.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGradedLaws.lean index cb12d46cde..cc2e8d31ce 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGradedLaws.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGradedLaws.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGraded +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGraded /-! # Laws of the graded line multiplication @@ -18,6 +20,8 @@ Each law descends from the corresponding two-index stage law of chain colimits, mirroring the homogeneous laws of `ChainAlgebra`. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBInd.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBInd.lean index 7550479b89..e73ce37b8c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBInd.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBInd.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCoeq +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCoeq /-! # The splitting chain in the ind-category @@ -55,6 +57,8 @@ therefore carried as a hypothesis, as in `RS.Classical.Deligne.SuperRealize`. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBNonzero.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBNonzero.lean index d0838d730f..6119ae2c18 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBNonzero.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBNonzero.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBInd -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowInduct +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBInd +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowInduct /-! # Nonvanishing of the chain algebra unit @@ -16,6 +18,8 @@ unit stage, and the power zigzag induction keeps every stage alive. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBofA.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBofA.lean index c5837d20cc..ed37d8a536 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBofA.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBofA.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainB -import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowDatum +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 @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBridge.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBridge.lean index 73177e544a..af2c61fb76 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBridge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBridge.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymDatum +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymDatum /-! # The bridge from the power chain to the splitting chain @@ -20,6 +22,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainDelta.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainDelta.lean index 179f9642ba..81dd9831fe 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainDelta.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainDelta.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMul -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing /-! # The transitions of the splitting chain @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns.lean index caea32641f..533f7141cc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.SecondSlot +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.SecondSlot /-! # Insertion maps into the splitting-chain stages diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/Base.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/Base.lean index 145c6a3256..4e087d2366 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/Base.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/Base.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainStage2 +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainStage2 /-! # Insertion maps into the splitting-chain stages @@ -32,6 +34,8 @@ the subject of [FirstSlot.lean](FirstSlot.lean) and symmetric multiplication, up to the arity transport. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/FirstSlot.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/FirstSlot.lean index 56a514308c..9c4f0465c0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/FirstSlot.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/FirstSlot.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.Base +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.Base /-! # The first-slot insertion against the stage structure @@ -21,6 +23,8 @@ transition. raising the merged arities by one on each side. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/SecondSlot.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/SecondSlot.lean index 4ee179d6f2..7252509beb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/SecondSlot.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainIns/SecondSlot.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.FirstSlot +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainIns.FirstSlot /-! # The second-slot insertion against the stage structure @@ -21,6 +23,8 @@ proofs need are established first. raising the merged arities by one on each side. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMul.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMul.lean index 0994083c40..b69d62c0c0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMul.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMul.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairMul +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairMul /-! # The multiplication of the chain algebra @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulHet.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulHet.lean index 1d43e46d99..accd4c9351 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulHet.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulHet.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra /-! # Heterogeneous multiplication of chain colimits @@ -21,6 +23,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulLaws.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulLaws.lean index 50395fce7e..ba70fd6179 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulLaws.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainMulLaws.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMul -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid /-! # Commutativity and associativity of the chain multiplication @@ -18,6 +20,8 @@ interchange `tensorμ`. Transports of chain stages along equalities of arities are packaged as `chainStageCast`. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainNonzero.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainNonzero.lean index f93e4afb65..52e64feb25 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainNonzero.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainNonzero.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBridge -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransfer +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBridge +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransfer /-! # Nonvanishing of the splitting-chain units @@ -20,6 +22,8 @@ powers (1.15.1), and the `δ` of a duality vanishes only on the zero module. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainShift.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainShift.lean index e3e4475090..81cd96f41f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainShift.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainShift.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra /-! # Shifting a chain colimit by one stage @@ -20,6 +22,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainStage2.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainStage2.lean index 404ce9a81e..9aefb00b3a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainStage2.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainStage2.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainDelta +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainDelta /-! # The two-index splitting-chain stages @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainUnit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainUnit.lean index 350c769ca8..2e3716fc96 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainUnit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainUnit.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.NatChain -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitStage +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 @@ -20,6 +22,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CharSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CharSplit.lean index b1511482ea..c7d419693d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CharSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CharSplit.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.RegularSum -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.Package +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RegularSum +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.Package /-! # Character splitting of the completed cycle product @@ -20,6 +22,8 @@ specialisation at a pointwise product of scalar sequences over pairs of shapes. -/ +@[expose] public section + namespace RS open Finset Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CommonAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CommonAlgebra.lean index 8fcdd3eec8..b107823a26 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CommonAlgebra.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CommonAlgebra.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndBigTensorUnit +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndBigTensorUnit /-! # A common extension of a family of algebras @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoprodPreserve.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoprodPreserve.lean index ae572e5cd4..a8ef0c8c86 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoprodPreserve.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoprodPreserve.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Preservation of coproducts from finite and filtered @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescent.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescent.lean index 01f0471a82..b743f80ddb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescent.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescent.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaCountable +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaCountable /-! # Countable descent for the witnessing algebras @@ -58,6 +60,8 @@ diagram is dominated by a single stage, whence `RS.exists_factor_of_mix_hom_colimit`. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescentClose.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescentClose.lean index d55aad50d3..2db6d4e8e8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescentClose.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableDescentClose.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ImageSubalgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndImage -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModAdjoint +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 @@ -59,6 +61,8 @@ hypothesis discharged from finite length by `RS.indImageEmbedded_of_lengthLE`. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableNullstellensatz.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableNullstellensatz.lean index 884af72bfe..53219babf0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableNullstellensatz.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CountableNullstellensatz.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # The countable Nullstellensatz over ℂ @@ -32,6 +34,8 @@ The finite-type predecessor is `RS.exists_algHom_complex` in Zariski's lemma instead of the dimension count. -/ +@[expose] public section + namespace RS /-- A field extension of ℂ of at most countable dimension is diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoverFactor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoverFactor.lean index dcebe5d68c..3cbb25d010 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoverFactor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CoverFactor.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PlainShuffle -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistPow +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 @@ -17,6 +19,8 @@ permutation action through the identification to the committed plain equivariance. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CycleSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CycleSplit.lean index 30515785f0..b379ad961b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/CycleSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/CycleSplit.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CharSplit +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CharSplit /-! # Additive splitting of the completed cycle product @@ -24,6 +26,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayCalculus.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayCalculus.lean index 7cc3849561..3249bd905a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayCalculus.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayCalculus.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayType +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayType /-! # The corepresentable calculus of Day convolution on `Type` @@ -31,6 +33,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayType.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayType.lean index 86635bfb7c..06c4a8ddd7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayType.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DayType.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Day convolution on `Type`-valued functor categories @@ -34,6 +36,8 @@ The Mathlib imports above are deliberate exceptions to the reachable from it. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory MonoidalCategory.DayFunctor Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DeligneAssembly.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DeligneAssembly.lean index 63ed3858a4..d18a4e5ef6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DeligneAssembly.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DeligneAssembly.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledSplit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreLinear -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal +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 @@ -70,6 +72,8 @@ and `RS.evenEmbedLinear_scalarUnit` reads that off for the even embedding. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DescentClose.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DescentClose.lean index 37fd679389..8dac817357 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DescentClose.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DescentClose.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichZig -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescentClose -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TrichotomyClose +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 @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DevissageBound.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DevissageBound.lean index 625c65848f..359792b310 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DevissageBound.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DevissageBound.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormalise -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchurSummand -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhiskerAll -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State +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 @@ -20,6 +22,8 @@ the mixed sum forces the diagram to contain the cell recording the two counts. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledAbelian.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledAbelian.lean index fac9fb0664..592b7c5ede 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledAbelian.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledAbelian.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling /-! # Abelianness of the doubling @@ -25,6 +27,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledGrowth.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledGrowth.lean index 0b21a513db..5cd991d170 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledGrowth.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledGrowth.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.TensorPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledAbelian +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 @@ -45,6 +47,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledLine.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledLine.lean index 4be8a665a5..a47682b8f3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledLine.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledLine.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 /-! # The odd line of the doubling @@ -17,6 +19,8 @@ general case of 2.11, where the category itself need not contain such an object. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledScalar.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledScalar.lean index 2d3cc511b9..8836d8b918 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledScalar.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledScalar.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling -import LeanPool.RegtsSevenster.RS.Definitions +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling +public import LeanPool.RegtsSevenster.RS.Definitions /-! # Scalars on the unit of the doubling @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSmall.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSmall.lean index ca39d7fafa..eaea727fbd 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSmall.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSmall.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Doubling /-! # The doubling is the square @@ -13,6 +15,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSplit.lean index 419d412583..2432e73812 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DoubledSplit.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitEverything -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21General +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitEverything +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21General /-! # The splitting algebra of the doubling @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Doubling.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Doubling.lean index 0e46f16b25..f4d928aebc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Doubling.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Doubling.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive /-! # The ℤ/2-graded doubling of a category @@ -32,6 +34,8 @@ componentwise matrix checks against the distributor calculus set up in the `Distributors` section. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.Limits MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DualityMate.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DualityMate.lean index f16ccc8573..31c4bd18b9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/DualityMate.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/DualityMate.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Duality-intertwining morphisms are invertible @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/EvenEmbedMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/EvenEmbedMonoidal.lean index 8f09d2270c..6943a539bf 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/EvenEmbedMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/EvenEmbedMonoidal.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledAbelian +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledAbelian /-! # The even embedding is strong braided monoidal @@ -32,6 +34,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ExactFromShort.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ExactFromShort.lean index a164e5df82..08092e703e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ExactFromShort.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ExactFromShort.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExact +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExact /-! # Exactness from short exact sequences @@ -20,6 +22,8 @@ homology. -/ +@[expose] public section + namespace RS open CategoryTheory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FactorialBeats.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FactorialBeats.lean index ac690cbe63..261a6bc554 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FactorialBeats.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FactorialBeats.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.FactorialBound +module + +public import LeanPool.RegtsSevenster.RS.Common.FactorialBound /-! # The square root of the factorial beats every geometric progression @@ -24,6 +26,8 @@ least `1`, and it then suffices to pick `m` beyond both `3 * b ^ 2` exceeding the constant (so the spare factor `2 ^ m` swallows it). -/ +@[expose] public section + namespace RS /-- Real form of `three_pow_mul_factorial_ge`: diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreAdditive.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreAdditive.lean index 041807d481..150b191bbc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreAdditive.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreAdditive.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModFunctor +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModFunctor /-! # The fibre functor is additive @@ -21,6 +23,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreBridge.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreBridge.lean index 5d116f4c8c..0229ad1110 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreBridge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreBridge.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMonoidal +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 @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreEps.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreEps.lean index 835c7edaab..d7832caf04 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreEps.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreEps.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle /-! # The unit comparison of the fibre functor @@ -18,6 +20,8 @@ components it is composition with the inverse right unitor of the algebra. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreExact.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreExact.lean index 8c67d179c9..b2eca1c734 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreExact.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreExact.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ExactFromShort +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ExactFromShort /-! # Exactness of the fibre functor from a base-change section @@ -45,6 +47,8 @@ the ambient category; for `Ind C` it is supplied by counterpart. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFaithful.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFaithful.lean index 0b203fa582..2947314e5c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFaithful.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFaithful.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModAdjoint +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModAdjoint /-! # The fibre functor is faithful @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFunctor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFunctor.lean index bda00f5205..bfa1f89f39 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFunctor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreFunctor.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom /-! # The fibre functor over an algebra @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreLinear.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreLinear.lean index bb20bac1df..ac979be316 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreLinear.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreLinear.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointFibre +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointFibre /-! # The fibre functor is complex-linear @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMix.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMix.lean index 45e068e123..2c8acac52c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMix.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMix.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreEps -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaShift +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 @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMonoidal.lean index 917634332d..db86d2e8c4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMonoidal.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMuNat -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreEps -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffleCoh -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModFunctor +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 @@ -49,6 +51,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMu.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMu.lean index 41adb5b506..551627b498 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMu.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMu.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor /-! # The monoidal comparison of the fibre functor @@ -21,6 +23,8 @@ formula, which is what makes the coherence of `ω` a computation in the ambient category alone. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMuNat.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMuNat.lean index 27e3f7c0e5..4f1241f079 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMuNat.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreMuNat.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMu +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMu /-! # Naturality of the monoidal comparison of the fibre functor @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverComplex.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverComplex.lean index 789e368c3d..6fc1dcfdec 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverComplex.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverComplex.lean @@ -4,11 +4,13 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescentClose -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMix -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfLinear -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointBaseChange -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitInd +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 @@ -67,6 +69,8 @@ of a mixed object as a free super module. steps 1 to 5. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverSplitting.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverSplitting.lean index edbbf8d313..5dd5e1b432 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverSplitting.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreOverSplitting.lean @@ -4,11 +4,13 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplittingAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreExact -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFaithful -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreBridge -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfMonoidal +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 @@ -31,6 +33,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreRestrict.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreRestrict.lean index 499294aa43..3f6e3ab74c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreRestrict.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreRestrict.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreStrong +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreStrong /-! # Restricting the fibre functor along a monoidal functor @@ -17,6 +19,8 @@ functor; the composite of that functor with the fibre functor is then strong monoidal. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreStrong.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreStrong.lean index c9550c421e..a38dfe6f5f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreStrong.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FibreStrong.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeFree +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 @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FiltNil.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FiltNil.lean index 50280f0b9c..c795dc2b82 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FiltNil.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FiltNil.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Nilpotency from a shifted finite filtration @@ -36,6 +38,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FlatLimit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FlatLimit.lean index 43d6a30e57..6d51d204d3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FlatLimit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FlatLimit.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # The limit theorem for flatness at a finite stage @@ -55,6 +57,8 @@ matrix — in particular the base change `Rⱼ ⊗_{R_{i₀}} M_{i₀}` — is projective, hence flat. -/ +@[expose] public section + namespace RS namespace FlatLimit diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeCollapseAlg.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeCollapseAlg.lean index 0a0543577b..df3588ddc6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeCollapseAlg.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeCollapseAlg.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow /-! # The collapse against the group-algebra action @@ -15,6 +17,8 @@ letters becomes, after collapsing the heads, the action on the ambient word under the head. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeMixRetract.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeMixRetract.lean index fb47da2dcd..e9f161d5dc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeMixRetract.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeMixRetract.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 /-! # The free modules of a finite biproduct as retracts @@ -17,6 +19,8 @@ additivity argument without ever forming a biproduct in the category of module objects. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModAdjoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModAdjoint.lean index bd1f82bb7d..bc817e9e73 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModAdjoint.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModAdjoint.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeMixRetract -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModFunctor +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeMixRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModFunctor /-! # The free–forgetful adjunction for module objects @@ -34,6 +36,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModBiprod.lean index 6751bc94e8..852193f9a0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModBiprod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModBiprod.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle /-! # Components of the free module on a biproduct @@ -25,6 +27,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModFunctor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModFunctor.lean index 27d218724d..a8c3410b3f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModFunctor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModFunctor.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreFunctor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor +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 `ω` @@ -18,6 +20,8 @@ comparison of the ambient category, and realization carries the comparison of (2.11.1). -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffle.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffle.lean index a5497ca45a..d90b2a74e2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffle.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffle.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 +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 @@ -17,6 +19,8 @@ modules: the bookkeeping of the mixed free part of the dévissage decomposition. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffleCoh.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffleCoh.lean index 2c8a219c4a..95dc392ae5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffleCoh.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModShuffleCoh.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid /-! # Coherence of the free-module shuffle @@ -35,6 +37,8 @@ generator, and that double twist is not the identity. Accordingly is the interchange identity `RS.tensorμ_braiding` behind it. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModTensor.lean index 5d7aaf672f..cf7338a3ce 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeModTensor.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair /-! # The relative tensor of two free modules @@ -25,6 +27,8 @@ first generator past the second algebra factor. `RS.gpair`, as the shuffle. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormalise.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormalise.lean index a62c0c4c26..62d5700ac4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormalise.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormalise.lean @@ -4,11 +4,13 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseStep -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeNormaliseBase -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowStage -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowDesc -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeCollapseAlg +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 @@ -22,6 +24,8 @@ and under it the descended group-algebra action becomes the ambient action under the head. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseBase.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseBase.lean index bccb866993..81e3f49827 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseBase.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseBase.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowInsert +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowInsert /-! # The one-letter normalisation @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseStep.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseStep.lean index 9529fa64a7..29c4c59917 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseStep.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeNormaliseStep.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePowInsert -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSlide +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 @@ -29,6 +31,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePow.lean index d7d046e682..cc432a746a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePow.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePow.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowCast -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PlainShuffle -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MuInterchange +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 @@ -24,6 +26,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowDesc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowDesc.lean index cc04643c9e..888370971f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowDesc.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowDesc.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffleCoh -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow +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 @@ -38,6 +40,8 @@ carrier is spelt `(freeMod A V).X` so that instance synthesis finds it. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowInsert.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowInsert.lean index 04d460a43b..055bf82bf4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowInsert.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreePowInsert.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow /-! # A section of the free collapse @@ -27,6 +29,8 @@ interchange, and the folded unit word contributes only a left unitor. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSlide.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSlide.lean index 28e07a6e30..89ad9c9923 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSlide.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSlide.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreePow /-! # Sliding a head along a word of free letters @@ -16,6 +18,8 @@ power says exactly that the slide is invisible after the projection. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSummand.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSummand.lean index 8b2294952e..5e7eef08e7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSummand.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeSummand.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModAdjoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModAdjoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle /-! # Free summands of free mixed modules @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeTwistPi.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeTwistPi.lean index 3e6d0544ad..4195f4a8ab 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeTwistPi.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/FreeTwistPi.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistFreeTensor +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistFreeTensor /-! # The free factor on the projection @@ -21,6 +23,8 @@ carries the algebra past the generator, reassociates, and acts. consumes. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaAlgebra.lean index 7d1cdb101f..0b9996b12a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaAlgebra.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaAlgebra.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperRealize +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperRealize /-! # The Γ-algebra of a commutative monoid object @@ -35,6 +37,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaBiprod.lean index 6f43a986a2..7337ddb72a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaBiprod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaBiprod.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModIso -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +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 @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaComplex.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaComplex.lean index 2429f53932..1231cc8c82 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaComplex.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaComplex.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleScalars -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PresentedQuotient +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 @@ -22,6 +24,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaCountable.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaCountable.lean index 516652859b..ae582b4694 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaCountable.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaCountable.lean @@ -4,11 +4,13 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableNullstellensatz -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.HomFinite -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEvenRing -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UniversalAlgebra +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 @@ -61,6 +63,8 @@ the countable Nullstellensatz, as a ℂ-point of the Γ-algebra (`RS.nonempty_superPoint_gammaAlgebra`). -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModule.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModule.lean index f4eea6fdef..2c1b2b74ab 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModule.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModule.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaAlgebra +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaAlgebra /-! # The Γ-module of a module object @@ -35,6 +37,8 @@ first triangle identity of the self-duality of the odd line, `RS.OddLine.evaluation_coevaluation`. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModuleFunctor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModuleFunctor.lean index 85e74cc27f..b68a40553c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModuleFunctor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaModuleFunctor.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom /-! # Realization as a functor on module objects @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPair.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPair.lean index fb8959c22b..27f0b1ac74 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPair.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPair.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModTensor +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) @@ -55,6 +57,8 @@ self-duality of the odd line, `RS.OddLine.evaluation_coevaluation`. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairAdd.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairAdd.lean index e292ba45c4..f3fa3d2592 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairAdd.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairAdd.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal /-! # Additivity for the comparison map @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeFree.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeFree.lean index 237f578a37..cc44bda574 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeFree.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeFree.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairFreeMix -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetractRight -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquareIso +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 @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeMix.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeMix.lean index 7cda1ac41f..18c94ddd98 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeMix.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairFreeMix.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetract -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairUnit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeMixRetract +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 @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairNat.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairNat.lean index b980b9529b..a8db21ecb5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairNat.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairNat.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal +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 @@ -48,6 +50,8 @@ reduces the naturality square to exactly those four instances. the two module objects. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetract.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetract.lean index 3052be4fc1..07a7a281c0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetract.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetract.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairNat -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairAdd +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 @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetractRight.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetractRight.lean index 95f38bb821..ba59c72f8c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetractRight.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairRetractRight.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairRetract -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeMixRetract +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 @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairUnit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairUnit.lean index c7ac2b2c9e..bd6dd347b6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairUnit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaPairUnit.lean @@ -4,11 +4,13 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModuleFunctor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPair -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal +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 @@ -26,6 +28,8 @@ module element on the odd-odd block braids `L` past `L`, which is `−1`. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaShift.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaShift.lean index 55d33bdf30..b47a9fc033 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaShift.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaShift.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoTwist -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModIso -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShift +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 @@ -31,6 +33,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaTwistLeft.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaTwistLeft.lean index 6627dc9e69..095b849988 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaTwistLeft.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GammaTwistLeft.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaShift -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistShuffle +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 @@ -34,6 +36,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GeneratorAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GeneratorAlgebra.lean index dad84b5d92..c5aeed5449 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GeneratorAlgebra.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GeneratorAlgebra.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescentClose -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndLocallyMixed -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndUnitNonzero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitInd +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 @@ -30,6 +32,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GrowthDichotomy.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GrowthDichotomy.lean index 7978c5ca44..6f5ce7c223 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/GrowthDichotomy.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/GrowthDichotomy.lean @@ -4,14 +4,16 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdempotentLength -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FactorialBeats -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BlockUnits -import LeanPool.RegtsSevenster.RS.Classical.Deligne.WhiskerFaithful -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorPowZero +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 @@ -29,6 +31,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/HomFinite.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HomFinite.lean index 3691330a15..7307ebcd3d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/HomFinite.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HomFinite.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple /-! # Finite length bounds Hom-dimension from the unit @@ -32,6 +34,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookMult.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookMult.lean index b26ee8287f..6cfe2ef27f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookMult.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookMult.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos /-! # Hook bounds on induction and Kronecker multiplicities @@ -20,6 +22,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookZero.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookZero.lean index 94fead8564..388787ac5b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookZero.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HookZero.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSeries +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSeries /-! # Hook vanishing for Jacobi–Trudi determinants @@ -23,6 +25,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean index 3e19073415..a9cec51a0f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdemCut.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermNat -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct +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 @@ -36,6 +38,8 @@ interface are plugged in elsewhere. the alternating power, definitionally. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdempotentLength.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdempotentLength.lean index 64953c1a9d..001187f9ca 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdempotentLength.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IdempotentLength.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Length /-! # Length lower bounds from orthogonal idempotents @@ -24,6 +26,8 @@ increasing: a collapse of consecutive kernels would factor orthogonality, contradicting `f (n + 1) ≠ 0`. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ImageSubalgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ImageSubalgebra.lean index e96482104e..6814003aa1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ImageSubalgebra.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ImageSubalgebra.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescent +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescent /-! # The algebra structure on the image tower @@ -47,6 +49,8 @@ cancels, so each reduces to the corresponding law in `A`. This is and, over a symmetric `C`, `IsCommMonObj` of the same. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndAllColim.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndAllColim.lean index 281c7c39bb..b0111ffa91 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndAllColim.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndAllColim.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCoeq -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoprodPreserve +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCoeq +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoprodPreserve /-! # The ind tensor preserves all small colimits @@ -18,6 +20,8 @@ which the coend presentations of §3 pass through the tensor product. -/ +@[expose] public section + namespace RS open CategoryTheory Limits MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndBigTensorUnit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndBigTensorUnit.lean index 8793489fc6..9d779b16c5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndBigTensorUnit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndBigTensorUnit.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensorUnit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndPointTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndAllColim +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 @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCoeq.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCoeq.lean index f5e53aa9a8..b869dbae1a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCoeq.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCoeq.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact +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 @@ -69,6 +71,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCompact.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCompact.lean index be23d7723a..3fe5f68179 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCompact.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndCompact.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndMonoidal +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndMonoidal /-! # Compactness of the embedded objects of the ind-completion @@ -36,6 +38,8 @@ of a filtered colimit of types (`Types.jointly_surjective'`, `Types.FilteredColimit.colimit_eq_iff`). -/ +@[expose] public section + namespace RS open CategoryTheory Limits Opposite diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndDayClosure.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndDayClosure.lean index 89579b5da6..894cc4a8c5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndDayClosure.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndDayClosure.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayCalculus +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.DayCalculus /-! # Ind-objects are closed under Day convolution @@ -34,6 +36,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndImage.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndImage.lean index 4dd129dd0a..226ccb5b8e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndImage.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndImage.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescent +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescent /-! # Embedded images from finite length @@ -38,6 +40,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean index 8bc82f3cb9..e7d0c0ef34 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndKill.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplit -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.RegularTrace +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 @@ -21,6 +23,8 @@ character combinatorics to the categorical direct-sum transfer of Schur vanishing. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndLocallyMixed.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndLocallyMixed.lean index fd8f18e841..ba81c0a65e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndLocallyMixed.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndLocallyMixed.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29Close -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchurKilled +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29Close +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchurKilled /-! # Embedded objects are locally mixed @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndMonoidal.lean index 2293486fce..f50cabb833 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndMonoidal.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndDayClosure +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndDayClosure /-! # The monoidal structure on ind-objects @@ -21,6 +23,8 @@ inherits the structure through `Ind.equivalence` and the full monoidal subcategory of the ind-property. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfLinear.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfLinear.lean index 02ed9bc72a..53a695d122 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfLinear.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfLinear.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaCountable -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchurKilled +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaCountable +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchurKilled /-! # ℂ-linearity of the embedding `C ⥤ Ind C` @@ -48,6 +50,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfMonoidal.lean index 837e031d5f..eada19ccb4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndOfMonoidal.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurTransport +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurTransport /-! # The embedding `C ⥤ Ind C` as a strong braided monoidal functor @@ -46,6 +48,8 @@ and `rightUnitor_hom_unit_app` fields of Mathlib's `CategoryTheory.MonoidalCategory.LawfulDayConvolutionMonoidalCategoryStruct`. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory MonoidalCategory.DayFunctor Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndPointTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndPointTensor.lean index 04fbfec5f3..cd07d89be1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndPointTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndPointTensor.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitStage +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 @@ -49,6 +51,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchur.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchur.lean index 7e9d344bee..ac686c68c5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchur.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchur.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing +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 @@ -55,6 +57,8 @@ Yoneda lemma, by one element — its value on the canonical element comparisons are decided by evaluating both sides there. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory MonoidalCategory.DayFunctor Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean index cb9040b71e..bb432a9a76 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSchurKilled.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfMonoidal +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfMonoidal /-! # Schur vanishing and exact pairings across `C ⥤ Ind C` @@ -45,6 +47,8 @@ as in the acceptance section of `RS.Classical.Deligne.ScalarLinear`: between `ψ` and an ambient linear structure is needed. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSimple.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSimple.lean index b8caf09ca9..23c2168afa 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSimple.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSimple.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear /-! # The ind-embedding preserves simplicity @@ -43,6 +45,8 @@ epimorphism in an abelian category is an isomorphism. monomorphism. -/ +@[expose] public section + namespace RS open CategoryTheory Limits MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplit.lean index 7c1d3b29d2..93cc677f9e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplit.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CycleSplit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedConc +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CycleSplit +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedConc /-! # Additive splitting of Schur specialisations @@ -26,6 +28,8 @@ the binomial count, and the character expansion of each block factor. -/ +@[expose] public section + namespace RS open Finset Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplitSection.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplitSection.lean index 6342bb5986..0569dc48ea 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplitSection.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndSplitSection.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchurKilled -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Ind +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 @@ -43,6 +45,8 @@ rigid, so the pullback taken in `C` has a right dual there, and comparison isomorphism. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean index 55df977c91..45a380fc5a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCompact +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndCompact /-! # Right-exactness of the tensor product on ind-objects @@ -59,6 +61,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndUnitNonzero.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndUnitNonzero.lean index c316db2d3b..ccb6800373 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndUnitNonzero.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndUnitNonzero.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple +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 @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitDatum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitDatum.lean index b579418204..a3ab0f9628 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitDatum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitDatum.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitBase -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitBase +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier /-! # The duality datum over the trivial base @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitState.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitState.lean index f5d8bbfcfb..55ffa6f88d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitState.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InitState.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State /-! # The initial state of the dévissage @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean index ab814ca98f..f43b999f63 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainStage2 -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainStage2 +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain /-! # The interchange is linear over the base @@ -19,6 +21,8 @@ structure morphism of the splitting-chain algebra multiplies through. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KernelPow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KernelPow.lean index 8f58fd9f15..0cfeea2c23 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KernelPow.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KernelPow.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.WordMap +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.WordMap /-! # The kernel of a tensor power of an epimorphism @@ -48,6 +50,8 @@ Three layers: joins but no indexed supremum. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.Limits MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemma.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemma.lean index 278fa2d2fa..9517bc5762 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemma.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemma.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModContractL -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainUnit +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 @@ -41,6 +43,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaClose.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaClose.lean index 6e67cf4ef3..1513a90d66 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaClose.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaClose.lean @@ -4,11 +4,13 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaData -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitMonHom -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitPairDef -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBNonzero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndAllColim +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 @@ -22,6 +24,8 @@ the seed. Nonvanishing is the stage-detection argument of the balanced line. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaData.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaData.lean index 9c46c3d075..fdba36126e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaData.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KeyLemmaData.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma /-! # The Key Lemma conclusion, in Deligne's insertion form @@ -26,6 +28,8 @@ nonvanishing argument is unaffected; the insertions live in degrees `±1`. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KillerNonempty.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KillerNonempty.lean index df3c919465..d8261defb8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KillerNonempty.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KillerNonempty.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing +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 @@ -15,6 +17,8 @@ every diagram, so a killed object is killed at some diagram with at least one cell. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean index 6a147efa43..5d69585d31 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/KronKill.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndKill +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndKill /-! # The Kronecker kill: diagonal products die with their multiplicity @@ -20,6 +22,8 @@ the multiplicity is. This mirrors the induction kill of by the two external embeddings and the diagonal. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/LambdaCoend.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/LambdaCoend.lean index 229ac16ff8..eb90bb4ee4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/LambdaCoend.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/LambdaCoend.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid /-! # The Λ coend of a pair of functors @@ -18,6 +20,8 @@ stage maps and dinaturality, the mapping property, and functoriality in both arguments. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits Opposite diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean index bf97babbda..1710e526b5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixSumPow +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixSumPow /-! # Mixed sums with degenerate counts @@ -28,6 +30,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffle.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffle.lean index 18af5e7cd1..039512a326 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffle.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffle.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 /-! # Peeling a unit summand off a mixed sum @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffleLine.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffleLine.lean index fb115898a2..862ecca175 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffleLine.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixShuffleLine.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle /-! # Peeling a line summand off a mixed sum @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixSumPow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixSumPow.lean index bd86b438d6..394db277a1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixSumPow.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixSumPow.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed /-! # Mixed sums as folded biproduct powers @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhisker.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhisker.lean index 992e563346..55d075933d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhisker.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhisker.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixSumPow +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixSumPow /-! # Whiskered nonvanishing of the mixed sum @@ -29,6 +31,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhiskerAll.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhiskerAll.lean index cd4571ab68..aaa8a0335d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhiskerAll.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixWhiskerAll.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixDegenerate -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhisker +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixDegenerate +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixWhisker /-! # The whiskered mixed sum at arbitrary counts @@ -19,6 +21,8 @@ every pair of counts and every diagram avoiding the corresponding cell. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedConc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedConc.lean index 9307c99089..97decef8ff 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedConc.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedConc.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm /-! # Concatenation of tensor powers and the block embedding @@ -30,6 +32,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedDiag.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedDiag.lean index bea36fe24f..753e809460 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedDiag.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedDiag.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Intertwine -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm +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 @@ -26,6 +28,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedTransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedTransport.lean index c0b5ab4bcd..7085456de7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixedTransport.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepATransport +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepATransport /-! # Transport of local mixedness along a base change @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAbelian.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAbelian.lean index 00582b608c..e23841ea63 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAbelian.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAbelian.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeBiprod +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 @@ -55,6 +57,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAssoc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAssoc.lean index fbcd350388..7dcfeb0497 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAssoc.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModAssoc.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws /-! # Associativity of the tensor product of modules @@ -29,6 +31,8 @@ target. forward map. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModBiprod.lean index cfbef5a5a9..557047508d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModBiprod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModBiprod.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor /-! # Biproducts of internal modules @@ -17,6 +19,8 @@ and morphisms out of the biproduct module are determined by the two components. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModContractL.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModContractL.lean index 8fed27facf..2c59d03aa8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModContractL.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModContractL.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModIns +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModIns /-! # Contraction of a leading dual pair on the multi-tensor @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModCross.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModCross.lean index 31919bb0d7..2223745665 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModCross.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModCross.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMulti +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMulti /-! # Crossing the monoid over a block of the multi-tensor @@ -36,6 +38,8 @@ two-element multi-tensor. relation, with its defining equation `modMultiπ_swapPair`. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModDual.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModDual.lean index 6c337d8248..665a6c2c65 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModDual.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModDual.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor /-! # The dual of a module object @@ -43,6 +45,8 @@ copairing, need the multi-tensor coherence layer and are outside this module's scope. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean index 76c3293c5b..b4c925a0da 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModCross +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModCross /-! # Insertion and contraction on the multi-tensor @@ -17,6 +19,8 @@ contraction descends through the coequalizer using the pairing's linearity. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMulti.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMulti.lean index 8942753570..9e64f0d90b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMulti.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMulti.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor /-! # The multi-tensor of internal modules over a monoid object @@ -60,6 +62,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMultiTriple.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMultiTriple.lean index ae782daafd..e4c03a2e1c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMultiTriple.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModMultiTriple.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMulti -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAssoc +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 @@ -35,6 +37,8 @@ product of `ModTensor.lean`. directions. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowCast.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowCast.lean index 7fb142db0b..1d2888aaf0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowCast.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowCast.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast +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 @@ -31,6 +33,8 @@ that die after the projection keep dying `modPowAlg_compat` follows. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescent.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescent.lean index 14072b338f..c0a2599d8c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescent.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescent.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModZero +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModZero /-! # The retract tower of a dualizable module @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescentClose.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescentClose.lean index 3cf40f0db0..badaf0aa1a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescentClose.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowDescentClose.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichMerge +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichMerge /-! # Descent of power vanishing to the module @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowStage.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowStage.lean index fa93e505f1..0896c2b3df 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowStage.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModPowStage.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg /-! # The module power, one letter at a time @@ -27,6 +29,8 @@ further letter. projection at one arity is invisible at the next. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchur.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchur.lean index 61a30ea079..32897dd622 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchur.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchur.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GrowthDichotomy -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IdemCut -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowCast -import LeanPool.RegtsSevenster.RS.Classical.Deligne.RowColIdem +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 @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchurSummand.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchurSummand.lean index 0446afde2b..c21775421e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchurSummand.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModSchurSummand.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchur -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod /-! # Module-level Schur vanishing passes to retracts @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean index 596c5ecb17..8a29df73c3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Tensor product of internal modules over a commutative monoid @@ -45,6 +47,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModZero.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModZero.lean index 8aa130a2bc..bfce9d89d7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModZero.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModZero.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor /-! # Vanishing transport through the module tensor product @@ -16,6 +18,8 @@ epic, and the ordinary tensor product with a zero object is zero. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MuInterchange.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MuInterchange.lean index 9a7925813b..760549cc98 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MuInterchange.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MuInterchange.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid /-! # The tensorμ interchange associativity @@ -16,6 +18,8 @@ twice. This is the symmetric-category companion of Mathlib's adjacent symmetry cancellation dissolves the doubled crossing. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MulBy.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MulBy.lean index 4334513837..61f7bc9395 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MulBy.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MulBy.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaAlgebra +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaAlgebra /-! # Multiplication by a scalar @@ -21,6 +23,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/NatChain.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NatChain.lean index 6f5946104c..cd90a024cb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/NatChain.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NatChain.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Functors out of the natural numbers from step data @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/NewtonConv.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NewtonConv.lean index 766f84d2a4..4369d96cd6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/NewtonConv.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NewtonConv.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums /-! # Convolution of complete homogeneous sequences @@ -26,6 +28,8 @@ Coefficient extraction yields the consumer-facing convolution formula for Jacobi–Trudi consumers. -/ +@[expose] public section + namespace RS open Finset PowerSeries diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/NullPoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NullPoint.lean index 9c187362cd..0dfd8d8c33 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/NullPoint.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/NullPoint.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Complex points of finite-type algebras @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLineMap.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLineMap.lean index 7dee6feb70..69e1a32bb0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLineMap.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLineMap.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 /-! # Transporting an odd line along a monoidal functor @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLinePairing.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLinePairing.lean index 820ebeadd6..01d4e0faa8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLinePairing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddLinePairing.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 /-! # The odd line is self-dual @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddParity.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddParity.lean index b2cb509b91..7a3c91472b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddParity.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddParity.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing /-! # Tensoring by the odd line swaps parity @@ -21,6 +23,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddPermSign.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddPermSign.lean index 0b5e85afea..26e9937344 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddPermSign.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddPermSign.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 /-! # The sign action on tensor powers of an odd line @@ -19,6 +21,8 @@ sign. The linear extension evaluates the group algebra's action on a single group element accordingly. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquare.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquare.lean index 366e02a1a1..cdc6284757 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquare.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquare.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModTensor /-! # Contracting the shuffle of two odd twists @@ -22,6 +24,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquareIso.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquareIso.lean index e8dd7ecc56..1893a0854b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquareIso.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/OddSquareIso.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddSquare -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreMu -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaShift -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShiftUnit +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 @@ -21,6 +23,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairCarrier.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairCarrier.lean index e988c7f6f9..0be5dd03be 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairCarrier.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairCarrier.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SeedIns +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SeedIns /-! # The pair product on the graded carrier @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairMul.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairMul.lean index 7ab5feb76a..4b5fa3a52a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairMul.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairMul.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowActMul +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowActMul /-! # The interchange of module tensor products @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairPerm.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairPerm.lean index 840d81e5f7..a10002d4ef 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PairPerm.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairing +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairing /-! # Permutations across the power pairing @@ -37,6 +39,8 @@ into the *order-reversing adjoint* permutation of the `M'`-slots. symmetric powers. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermNat.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermNat.lean index 28b25830f0..bd5fcc7db6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermNat.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermNat.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Intertwine -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact +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 @@ -27,6 +29,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermRepChar.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermRepChar.lean index 0fa4cbb655..ef1f6b42d4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermRepChar.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PermRepChar.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CharSplit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSeries -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignedTensor +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 @@ -26,6 +28,8 @@ Schur specialisation as the dimension of an equivariant Hom space. -/ +@[expose] public section + namespace RS open Finset Equiv MonoidAlgebra diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PieriPos.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PieriPos.lean index 5f1108c3f3..0f2664d27f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PieriPos.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PieriPos.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.HookZero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.NewtonConv -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperValues +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 @@ -35,6 +37,8 @@ specialisations. the nonvanishing direction of Deligne 1.9 on the character side. -/ +@[expose] public section + namespace RS open Finset Matrix diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PlainShuffle.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PlainShuffle.lean index 8d5fa67420..b17977798f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PlainShuffle.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PlainShuffle.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedDiag +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedDiag /-! # The plain diagonal shuffle and its equivariance @@ -28,6 +30,8 @@ equivariance statements in the form the plain tensor-power calculus consumes. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointBaseChange.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointBaseChange.lean index cd6ccd6bfa..419ce48f0c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointBaseChange.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointBaseChange.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaPairAdd -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShiftUnit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperPointMod +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 @@ -59,6 +61,8 @@ finite-dimensional spaces is finite-dimensional. `RS.freeEvenEquivFin`, `freeOddEquivFin`. -/ +@[expose] public section + namespace RS open CategoryTheory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointFibre.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointFibre.lean index 52445b7977..ae0677a19f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointFibre.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointFibre.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverComplex -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverSplitting +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverComplex +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverSplitting /-! # The fibre functor into super vector spaces @@ -77,6 +79,8 @@ algebra being a monomorphism — vanishes itself. (`RS.deligneFibre_faithful`). * `RS.exists_deligneFibre_of_point`: the four properties packaged. -/ + +@[expose] public section namespace RS open CategoryTheory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal.lean index 339594c84c..e297ae5049 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Functor +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Functor /-! # The monoidal comparison for base change at a complex point diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Calculus.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Calculus.lean index de6ed4a7b1..932b5ce501 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Calculus.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Calculus.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Comparison +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Comparison /-! # A point-free calculus for the two tensor products @@ -41,6 +43,8 @@ proved in [Coherence.lean](Coherence.lean). threefold graded tensor product. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean index 1bb1e2e0c5..41c1c34648 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Calculus +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Calculus /-! # Coherence and invertibility of the comparison @@ -39,6 +41,8 @@ strength of base change along an algebra map, in super form. are invertible. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Comparison.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Comparison.lean index c26531d5ed..68d03ea441 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Comparison.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Comparison.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Residue +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Residue /-! # The comparison in super vector spaces, and its inverse @@ -44,6 +46,8 @@ hypothesis is needed. tensor product of super vector spaces. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Functor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Functor.lean index 2f5947fabc..7fd7b38b5a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Functor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Functor.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Coherence +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointMonoidal.Coherence /-! # The monoidal fibre functor at a complex point @@ -30,6 +32,8 @@ gives a braided fibre functor out of the ambient category. splitting algebra at a complex point is braided. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean index 8a94816cb6..3e3447ac54 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Residue.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointFibre +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PointFibre /-! # The residue algebra of a complex point @@ -44,6 +46,8 @@ The comparison is carried down to super vector spaces in generator computations consume. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointTensor.lean index d52f5b0a6d..e6799e5bb3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointTensor.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitSimple /-! # Points of objects tensor without vanishing @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowAct.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowAct.lean index dfb1c3a897..e3f8780b29 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowAct.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowAct.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul /-! # The monoid action on module powers and symmetric powers @@ -33,6 +35,8 @@ symmetric power a module again. * `modPowMod`/`symPowMod`: the bundled modules. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowActMul.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowActMul.lean index 1dca1b5d52..bf17393643 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowActMul.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowActMul.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct /-! # Compatibility of the module-power action with the multiplication @@ -34,6 +36,8 @@ into `A`-module algebras. equivariance of the descended action. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowChain.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowChain.lean index 94145c22a7..c5a4d00d8e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowChain.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowChain.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainDelta +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainDelta /-! # The power-level chain and the copairing powers @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowCopairing.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowCopairing.lean index 5d3144a6fb..f13b3afe16 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowCopairing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowCopairing.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairing +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairing /-! # The power copairing @@ -23,6 +25,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowDatum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowDatum.lean index 5d82705372..4ab271e557 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowDatum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowDatum.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZig -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagNonzero +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZig +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagNonzero /-! # The power duality datum @@ -24,6 +26,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowInduct.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowInduct.lean index fb24f9ef98..9cb07acc75 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowInduct.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowInduct.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainNonzero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPairSucc -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSuccMod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZigzag +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 @@ -19,6 +21,8 @@ transfer and the step is the tensor inheritance transferred along the merge. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowMerge.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowMerge.lean index 77c706656e..21752d8dc3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowMerge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowMerge.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain /-! # The merge isomorphism for module powers @@ -33,6 +35,8 @@ concatenation of ambient tensor powers. forward direction and `powSplit` as the inverse. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairSucc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairSucc.lean index 07d1121169..8d485e54df 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairSucc.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairSucc.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSucc +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSucc /-! # The pair side of the power step @@ -19,6 +21,8 @@ rearrangement itself is the retraction `tensorMu_braid_retract`, a pure braid coherence. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean index 52abbf96eb..cfb09e1f85 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowAct /-! # The power pairing @@ -21,6 +23,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPoint.lean index b70567aa1f..6b1f790c75 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPoint.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPoint.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermNat -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitMod +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 @@ -19,6 +21,8 @@ monomorphism are monomorphisms. The substrate of the nonvanishing of the local splitting algebra. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSucc.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSucc.lean index 93c8eda909..aa64928ea8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSucc.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSucc.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBofA -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorZigzag +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBofA +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorZigzag /-! # The successor power datum @@ -17,6 +19,8 @@ extension principle reduces the comparison to the unit elements, where the chain recursion is definitional. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSuccMod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSuccMod.lean index ee0bb67129..9e9b705859 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSuccMod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowSuccMod.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowMerge +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowMerge /-! # Module-level inverses of the merge maps @@ -26,6 +28,8 @@ back — become isomorphisms of modules. inverse, with roundtrips. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowTriangle.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowTriangle.lean index 0360c30c54..3e878a61a7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowTriangle.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowTriangle.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowChain +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainMulLaws /-! # The triangle scalar of the power chain @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZig.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZig.lean index 8d7fe41271..04f0aa8924 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZig.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZig.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowTriangle +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowTriangle /-! # The carrier calculus of the power chain @@ -16,6 +18,8 @@ copairing (`RS.zigCarrier`), with their naturality in the module and their evaluation on scalars. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZigzag.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZigzag.lean index e958002c91..32d63316ac 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZigzag.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowZigzag.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransfer +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransfer /-! # The power datum inherits the zigzag laws @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PresentedQuotient.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PresentedQuotient.lean index 2f86248218..1b107233cc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PresentedQuotient.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PresentedQuotient.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndImage +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndImage /-! # Quotients of countably presented ind-objects @@ -48,6 +50,8 @@ of a countably presented ind-object is of at most countable dimension any of its quotients (`RS.rank_hom_unit_le_aleph0_of_epi`). -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21.lean index 4b961086a7..c92a5c9c84 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21Core -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreOverSplitting -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSimple +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 @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21Core.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21Core.lean index 7ff8132a89..32d8fe62c5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21Core.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21Core.lean @@ -4,11 +4,13 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplittingAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndLocallyMixed -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplitSection -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndUnitNonzero -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitInd +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 @@ -20,6 +22,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21General.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21General.lean index 98c6db119e..f08455785b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21General.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop21General.lean @@ -4,13 +4,15 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop21 -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledLine -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledScalar -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DoubledGrowth -import LeanPool.RegtsSevenster.RS.Classical.Deligne.EvenEmbedMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLineMap -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarUnitEquiv +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 @@ -35,6 +37,8 @@ functor — is supplied by the growth dichotomy `RS.forall_exists_schurKilled`, applied to the doubling. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29.lean index 44b7985daf..f0f4340237 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaData -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing +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 @@ -18,6 +20,8 @@ unit with braiding `−1`; local means after base change to some nonzero commutative algebra. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29Close.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29Close.lean index d4df9b3d88..7c188cfe36 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29Close.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29Close.lean @@ -4,11 +4,13 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DevissageBound -import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepB -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DescentClose -import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitState -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KillerNonempty +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 @@ -20,6 +22,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29State.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29State.lean index 27faea04de..24e699c35e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29State.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Prop29State.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29 -import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow +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 @@ -21,6 +23,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210.lean index 8262b6b5dd..6c10caabf0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaData +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaData /-! # The local splitting statement @@ -16,6 +18,8 @@ splitting is a section of the base-changed epimorphism as module maps over the algebra. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Bridge.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Bridge.lean index 35d69ea4b7..a8ab7a6e3b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Bridge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Bridge.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoverFactor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Chain +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 @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Chain.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Chain.lean index 62b008e297..52cd7ebdfa 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Chain.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Chain.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymMul +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainAlgebra /-! # The local splitting chain @@ -19,6 +21,8 @@ laws assemble the colimit into a commutative algebra through the generic chain kit. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Close.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Close.lean index ced46e174f..d3680f57d1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Close.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Close.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Bridge -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Reduce +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 @@ -18,6 +20,8 @@ ind-category follows from the stage units through the filtered criterion. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Ind.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Ind.lean index e323f597f4..1baf9e65e3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Ind.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Ind.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBInd -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210Close +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 @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Reduce.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Reduce.lean index 8703514929..0f1c97ae2c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Reduce.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/Rappel210Reduce.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowPoint +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Rappel210 /-! # Exactness of tensoring with a dualizable object @@ -18,6 +20,8 @@ tensoring, which produces the internal-hom extension that the pullback stage consumes. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean index a08881205b..401d2a1aea 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RegularSum.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeAlgebra -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly -import LeanPool.RegtsSevenster.RS.Classical.SymFun.PieriChain +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 @@ -33,6 +35,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoBiprod.lean index 3b79c3310e..dc32863e56 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoBiprod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoBiprod.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoTwist +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.RhoTwist /-! # The realization of a biproduct @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoTwist.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoTwist.lean index 33553d2fb5..edbc1add15 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoTwist.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RhoTwist.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddParity +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddParity /-! # The realization of a twisted object @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RowColIdem.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RowColIdem.lean index 030a5db372..9d9decc102 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/RowColIdem.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/RowColIdem.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos /-! # The one-row and one-column idempotents @@ -30,6 +32,8 @@ forces dimension one, and the idempotents coincide with the symmetriser and antisymmetriser on the nose. -/ +@[expose] public section + namespace RS open Finset Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichMerge.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichMerge.lean index 43311f9940..afe3a5263c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichMerge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichMerge.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAssoc -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModPowDescent -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistPow +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 @@ -29,6 +31,8 @@ letters `M'`). descends to every tower stage. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichRetract.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichRetract.lean index 61a8c73c18..3c0b274051 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichRetract.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichRetract.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTensor +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle /-! # The sandwich retract legs @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichZig.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichZig.lean index 558c818732..5f8b41a69d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichZig.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SandwichZig.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMultiTriple -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagSandwich +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModMultiTriple +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagSandwich /-! # The sandwich retract of the zig triangle @@ -18,6 +20,8 @@ supplies those two readings, `RS.sandwichIns_hom` and `RS.modTensorπ_sandwichCon`. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarBraiding.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarBraiding.lean index 0697afb9e7..caf43c993d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarBraiding.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarBraiding.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.UnitEnd -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodTransfer +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 @@ -24,6 +26,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarLinear.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarLinear.lean index 26009fb5d2..1e23076620 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarLinear.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarLinear.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndTensorExact +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm /-! # ℂ-linearity from the scalar unit @@ -42,6 +44,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitEquiv.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitEquiv.lean index 71fc921a43..a332a792bd 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitEquiv.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitEquiv.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Definitions +module + +public import LeanPool.RegtsSevenster.RS.Definitions /-! # The scalar unit as a ring isomorphism @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitInd.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitInd.lean index ecfba13f1d..e0a1e49755 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitInd.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ScalarUnitInd.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear /-! # The scalar-unit hypothesis from a scalar unit @@ -16,6 +18,8 @@ ind-completion this supplies the hypothesis upstairs from the one downstairs. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean index 8898450b54..9c4fc428c0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurTransport.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSchur -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear -import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarTrace +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` @@ -38,6 +40,8 @@ embedded object is Schur vanishing downstairs. instantiation `RS.schurKilled_indOf_iff_of_hasScalarUnit`. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory MonoidalCategory.DayFunctor Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurVanishing.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurVanishing.lean index 7208516037..63271c0aca 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurVanishing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SchurVanishing.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast /-! # Schur-functor vanishing at the idempotent level @@ -23,6 +25,8 @@ block, and `permAlg_compat` carries the vanishing of `e λ`'s action up the standard embedding. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean index e1ec77d21b..9626b9fe0f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGr +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ChainBGr /-! # The seed entries of the splitting data @@ -17,6 +19,8 @@ of the `ofBase`, `ins` and `ins'` fields of the splitting data of the Key Lemma. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeAlgebra.lean index 08079ea94c..dbdd7dbb3d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeAlgebra.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeAlgebra.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ShapeFintype -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage +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 @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeFintype.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeFintype.lean index 818148bb85..1b7c556558 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeFintype.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ShapeFintype.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams +module + +public import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams /-! # Young diagrams of a fixed size @@ -15,6 +17,8 @@ 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 -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SignConj.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SignConj.lean index 462c32d3f4..092cf113f5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SignConj.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SignConj.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CoverFactor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.AltPow -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddPermSign +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 @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleGenerator.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleGenerator.lean index 532a4b132b..5294a8e42c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleGenerator.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleGenerator.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GeneratorAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GeneratorAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient /-! # A simple algebra splitting the tensor generator @@ -22,6 +24,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimplePoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimplePoint.lean index c5c2ab131e..371c6c237b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimplePoint.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimplePoint.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaComplex +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaComplex /-! # The complex point of a simple algebra @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleQuotient.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleQuotient.lean index 903fa06802..a5b072d8ec 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleQuotient.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleQuotient.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CountableDescentClose -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KernelPow +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 @@ -15,6 +17,8 @@ algebra which is simple as an algebra: its only ideals are `⊥` and `⊤`. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleScalars.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleScalars.lean index 430d720a43..0833213cd5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleScalars.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleScalars.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MulBy +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MulBy /-! # The scalars of a simple algebra @@ -30,6 +32,8 @@ under either alternative of simplicity the action vanishes (`RS.hom_oddLine_eq_zero_of_simple`). -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean index 32a3ecf97e..e541c7e8bd 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SimpleSplit.lean @@ -4,11 +4,13 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleQuotient -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeSummand -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffleLine -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModAbelian +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 @@ -66,6 +68,8 @@ epimorphism out of a free mixed module splits of the local splitting statement without constructing it by hand. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SmallReduction.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SmallReduction.lean index 090c06518c..3598b10e8b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SmallReduction.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SmallReduction.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneTheorem +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneTheorem /-! # Deligne's theorem reduced to a genuinely small category @@ -35,6 +37,8 @@ monoidal structure transported along `CategoryTheory.equivSmallModel` `RS.DeligneFibreFunctor.precompose`. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.Limits MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAdjoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAdjoint.lean index 606d46a5c1..41d34b40a2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAdjoint.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAdjoint.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeAdjoint +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeAdjoint /-! # Adjointness of the split idempotents @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean index 8840874285..6d8bd3fb9b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SeedIns +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SeedIns /-! # Assembly of the splitting-data entries on the graded carrier @@ -20,6 +22,8 @@ the base entry, in the exact shape of the splitting data of the Key Lemma. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitClosure.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitClosure.lean index f7dfc24b11..7247f69b6e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitClosure.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitClosure.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreRestrict -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffleLine +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreRestrict +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffleLine /-! # The objects split by a fixed algebra @@ -30,6 +32,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitComplement.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitComplement.lean index 4809261889..1300f087ce 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitComplement.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitComplement.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtract -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitExtract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod /-! # The complement of the split factor @@ -16,6 +18,8 @@ complement of the split unit factor, and carries the descended action. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitEverything.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitEverything.lean index 8aec3cd2fc..e05abe6d4e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitEverything.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitEverything.lean @@ -4,12 +4,14 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleGenerator -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimplePoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitClosure -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndOfLinear -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SimpleSplit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SmallReduction +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 @@ -25,6 +27,8 @@ algebra are the complex numbers, so its Γ-algebra has a complex point. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExact.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExact.lean index d66de09c42..40977f4a13 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExact.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExact.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModAbelian +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreAdditive +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModAbelian /-! # Split short exact sequences and additive functors @@ -28,6 +30,8 @@ naming the general statements at the shape in which they are consumed. -/ +@[expose] public section + namespace RS open CategoryTheory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtract.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtract.lean index 5c07e24ece..5272f570d7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtract.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtract.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowCopairing /-! # Factor extraction from splitting data @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtractDual.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtractDual.lean index 43bfd6f70d..042a33a3c5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtractDual.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitExtractDual.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitComplement +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitComplement /-! # Factor extraction on the dual module @@ -20,6 +22,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean index f5248935eb..6c5e08b413 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAssemble +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAssemble /-! # The base entry is multiplicative @@ -17,6 +19,8 @@ monoid-morphism property of the base entry of the splitting data. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitPairDef.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitPairDef.lean index ba7639cad0..b8b40a129f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitPairDef.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitPairDef.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAssemble -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairCarrier +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 @@ -19,6 +21,8 @@ equation of the pair product field of the splitting data of the Key Lemma. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitReduce.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitReduce.lean index d2fba3672c..2197d3c4f2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitReduce.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitReduce.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact /-! # Sections through the dual: the reduction of 2.10 @@ -17,6 +19,8 @@ the splitting-algebra argument then only ever meets maps out of the unit. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitTransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitTransport.lean index 5cfd120e78..6e6da91654 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitTransport.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedTransport -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTransport +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 @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplittingAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplittingAlgebra.lean index 2647e6285f..a2ebc3ac04 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplittingAlgebra.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplittingAlgebra.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UniversalAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreRestrict +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UniversalAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.FibreRestrict /-! # The splitting algebra of the embedded category @@ -18,6 +20,8 @@ hypotheses under which the fibre functor over that algebra is strong monoidal and exact. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StateTransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StateTransport.lean index c4c5c11c5b..d7678c1aaa 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StateTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StateTransport.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle +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 @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepA.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepA.lean index 414cf04762..d4902f3a35 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepA.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepA.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemmaClose -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitAdjoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State +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 @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepATransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepATransport.lean index 5a7bd4bc20..93f7e20071 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepATransport.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepATransport.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeFree -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffle +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 @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepB.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepB.lean index 8b7a2a3cf9..b950b1fb03 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepB.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/StepB.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.StepA -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistState -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistSymPow +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 @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed.lean index fc3deb7c31..cd38c3de35 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Standard +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Standard /-! # Transport of the standard nonvanishing into the ambient category diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Letters.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Letters.lean index 9c0798e1cf..f3d8f4c31a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Letters.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Letters.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Signs +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Signs /-! # Letter systems and the sign transport @@ -31,6 +33,8 @@ that transports; the two systems it is applied to are built in tensor power exactly when its colour sums vanish. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Signs.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Signs.lean index 7899874c15..7e2d27fb56 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Signs.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Signs.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarBraiding -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperVectSchur +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 @@ -26,6 +28,8 @@ categorical side consumes it in [Letters.lean](Letters.lean). `parSign_swap` on an adjacent transposition. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean index bfceae6825..e0e6c1fb85 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Letters +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed.Letters /-! # The standard super object and the mixed sum @@ -32,6 +34,8 @@ as well — contradicting `not_schurKilled_stdSuper`. of `schurKilled_unit_odd`. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEvenRing.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEvenRing.lean index c932a70f11..bef8e02a47 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEvenRing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEvenRing.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.NullPoint -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperRealize +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 @@ -37,6 +39,8 @@ top of them. [NullPoint.lean](NullPoint.lean). -/ +@[expose] public section + namespace RS universe u u' diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGamma.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGamma.lean index 173a0333a1..aa757731d0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGamma.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGamma.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSmall +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperSmall /-! # The four-block Γ-algebra of a commutative monoid at an odd line @@ -51,6 +53,8 @@ an `RS.SuperCommAlgebra`, feeding the odd-nil quotient theory of `RS.SuperRealize`. -/ +@[expose] public section + namespace RS noncomputable section diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean index af4b8954f0..62937c9c6c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperGamma -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEmbed -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurTransport +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` @@ -46,6 +48,8 @@ generator `indOf.obj sOdd`, and the three hypotheses are proved. the scalar unit as in `RS.ScalarLinear`. -/ +@[expose] public section + namespace RS noncomputable section diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModAbelian.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModAbelian.lean index ff1bdf1604..0566579112 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModAbelian.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModAbelian.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod /-! # Super modules form an abelian category @@ -42,6 +44,8 @@ identities, so each survives verbatim in a submodule and in a quotient. -/ +@[expose] public section + namespace RS open CategoryTheory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprod.lean index 6166697ad0..8b2f4fd4ad 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprod.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom /-! # Biproducts of super modules @@ -29,6 +31,8 @@ biproducts then follow formally from the zero object and the binary ones. -/ +@[expose] public section + namespace RS open CategoryTheory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprodMap.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprodMap.lean index bc082c832f..9d1e745af2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprodMap.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModBiprodMap.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModIso +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModIso /-! # Functoriality of the biproduct of super modules @@ -15,6 +17,8 @@ biproducts, componentwise; a pair of isomorphisms induces an isomorphism. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModHom.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModHom.lean index 334987c503..717ec73aea 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModHom.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModHom.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule /-! # Morphisms of super modules @@ -15,6 +17,8 @@ four action blocks. Postcomposition with a morphism of module objects realizes one. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModIso.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModIso.lean index 21ae03106c..7f588f1fac 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModIso.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModIso.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModHom /-! # Recognising isomorphisms of super modules @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModMonoidal.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModMonoidal.lean index ca80528bf1..d25c238ecd 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModMonoidal.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModTensor +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModTensor /-! # The symmetric monoidal structure on super modules @@ -41,6 +43,8 @@ morphisms out of a two-, three- and four-fold tensor product. `MonoidalCategory` and `SymmetricCategory` instances. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShift.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShift.lean index 59f6b3a6e4..dd9ca07acb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShift.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShift.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule /-! # The parity shift of a super module @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShiftUnit.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShiftUnit.lean index 456404dd6c..9184e5ed15 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShiftUnit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModShiftUnit.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModMonoidal -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperModShift +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 @@ -44,6 +46,8 @@ degree and `+1` in odd degree. * `RS.SuperCommAlgebra.Mod.shiftUnitTensor`: the isomorphism. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModTensor.lean index 9bbe7edb9e..7f5f72687d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperModTensor.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule /-! # The tensor product of two super modules @@ -68,6 +70,8 @@ the construction needs a *commutative* base. packaged as `exists_unique_liftEven` and `exists_unique_liftOdd`. -/ +@[expose] public section + namespace RS open scoped TensorProduct diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperPointMod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperPointMod.lean index 3a69a26876..a85879b7ef 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperPointMod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperPointMod.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEvenRing -import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperEvenRing +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.GammaModule /-! # The residue module of a complex point @@ -17,6 +19,8 @@ which is consistent exactly because a point kills the products of two odd elements. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean index fce29bae24..f1a4f300d3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear /-! # Realization of ind-super-objects as super algebras @@ -47,6 +49,8 @@ layers. values on `C`. -/ +@[expose] public section + namespace RS /-! ## Super-commutative ℂ-algebras as graded pairs -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSeries.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSeries.lean index f290a7461d..0d3f8d4c28 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSeries.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSeries.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums -import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialH +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialH /-! # Super power sums and their generating series @@ -25,6 +27,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSmall.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSmall.lean index d47e8a730d..6cc81848a1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSmall.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperSmall.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperRealize +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SuperRealize /-! # A small model of `SuperVect` @@ -58,6 +60,8 @@ all reachable through the funnel; `isBilimitOfTotal` lives in the root `CategoryTheory.Limits` namespace, not on `Bicone`. -/ +@[expose] public section + namespace RS noncomputable section diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperValues.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperValues.lean index 5210a8299f..04aea6f87d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperValues.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperValues.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.IndSplit -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PermRepChar +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 @@ -18,6 +20,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean index 9a2af897dc..90f3046cb0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PieriPos -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SchurVanishing -import LeanPool.RegtsSevenster.RS.Classical.Super.TotalSpace +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 @@ -27,6 +29,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymAlg.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymAlg.lean index 1965245940..395edefb25 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymAlg.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymAlg.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedConc +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 @@ -51,6 +53,8 @@ frame machinery below are the concatenation substrate they will consume. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymDatum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymDatum.lean index ed068279b8..9eb4daaa14 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymDatum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymDatum.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowDatum +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowDatum /-! # The symmetric power duality datum @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean index 0ef4b8c786..1670febbfd 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg /-! # Multiplication on symmetric module powers @@ -41,6 +43,8 @@ braided category the `tensorRight` mirror follows — together with intended consumers. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorDatum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorDatum.lean index 135b28da3f..b5f8ab3373 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorDatum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorDatum.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.InterchangeAct /-! # The tensor product of duality data @@ -17,6 +19,8 @@ descended interchange exists because the interchange is linear in both factors. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorExact.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorExact.lean index a5cb68cc84..614297cdd6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorExact.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorExact.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Definitions +module + +public import LeanPool.RegtsSevenster.RS.Definitions /-! # Tensoring is exact in a rigid abelian category @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorMuBraid.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorMuBraid.lean index 59e7e46f0f..05bd298092 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorMuBraid.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorMuBraid.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # The interchange `tensorμ` intertwines the braidings @@ -25,6 +27,8 @@ exchange of the disjoint crossings `β_ a c` and `β_ b d` produces the right-hand side. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorPowZero.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorPowZero.lean index 267aa98116..8466aa4e70 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorPowZero.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorPowZero.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive -import LeanPool.RegtsSevenster.RS.Definitions +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.WhiskerAdditive +public import LeanPool.RegtsSevenster.RS.Definitions /-! # A vanishing tensor power forces a vanishing object @@ -26,6 +28,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorTransfer.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorTransfer.lean index d7d3decdcb..c8e1b22ec1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorTransfer.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorTransfer.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodTransfer -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KronKill -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixedDiag +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 @@ -24,6 +26,8 @@ multiplicity pushes a bounding-box cell into `μ'` or `ν'` (Deligne 1.12). -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorZigzag.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorZigzag.lean index 611e6f3aa0..37282bc080 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorZigzag.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TensorZigzag.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MuInterchange -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZagAction -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier +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 @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TrichotomyClose.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TrichotomyClose.lean index 53fc62f65a..e9be1a0420 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TrichotomyClose.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TrichotomyClose.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchur -import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModSchur +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.Prop29State /-! # The trichotomy, closed over a descent @@ -18,6 +20,8 @@ remainder. The descent is a parameter, discharged by the sandwich retract. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistBiprod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistBiprod.lean index 653b4c8287..6690168bfc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistBiprod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistBiprod.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistShuffle +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistShuffle /-! # Twisting distributes over the biproduct of modules @@ -22,6 +24,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistCoherence.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistCoherence.lean index 658ab9fe97..53e1f7629f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistCoherence.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistCoherence.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorMuBraid /-! # The twist-shuffle coherence @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistDatum.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistDatum.lean index 31df662b44..63987dedaf 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistDatum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistDatum.lean @@ -4,14 +4,16 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitFreeMod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistFreeTensor -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransferIso -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorZigzag -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BaseChangeTransport -import LeanPool.RegtsSevenster.RS.Classical.Deligne.InitDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.OddLinePairing -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BigTensor +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 @@ -26,6 +28,8 @@ along the twist shuffle gives the odd twist of a duality datum, zigzag laws included. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistFreeTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistFreeTensor.lean index 883e6f4871..154cc47eef 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistFreeTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistFreeTensor.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistUnitor +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistUnitor /-! # The free module inside the relative tensor @@ -21,6 +23,8 @@ braiding. a module is the twist of that module by the generating object. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistMixLine.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistMixLine.lean index e9c4fddfc8..656f36942a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistMixLine.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistMixLine.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffleLine +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.MixShuffleLine /-! # Tensoring a mixed sum with the odd line @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistPow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistPow.lean index 21f2091033..6529996197 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistPow.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistPow.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowSuccMod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PowZigzag -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistShuffle +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 @@ -16,6 +18,8 @@ isomorphisms: the two transport devices consumed by the k-fold twisted power identification. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistShuffle.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistShuffle.lean index 588283aafd..270878a8ef 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistShuffle.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistShuffle.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistCoherence +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorDatum +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistCoherence /-! # The twist shuffle @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistState.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistState.lean index 39d7b1e2d5..3a22268981 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistState.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistState.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistBiprod -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistMixLine -import LeanPool.RegtsSevenster.RS.Classical.Deligne.StateTransport +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 @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistSymPow.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistSymPow.lean index 2da71b8d82..2769a4a9a6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistSymPow.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistSymPow.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SignConj -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TrichotomyClose +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SignConj +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TrichotomyClose /-! # Symmetric powers of an odd twist @@ -17,6 +19,8 @@ zero both are the tensor unit, so the exchange holds there too. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistUnitor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistUnitor.lean index ce5c1f4966..846e9b5730 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistUnitor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/TwistUnitor.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.FreeModShuffle -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TwistShuffle +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 @@ -28,6 +30,8 @@ actions. twist of the free module, through the carrying isomorphism. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitBase.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitBase.lean index 1be91aed6d..7cf4ca5c76 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitBase.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitBase.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ModBiprod /-! # Modules over the tensor unit @@ -24,6 +26,8 @@ collapses to the ambient category. whose carrier is zero collapses to the other summand. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitFreeMod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitFreeMod.lean index 678a8e0158..eacf4ea32c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitFreeMod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitFreeMod.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitBase +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.UnitBase /-! # The trivial module as a free module @@ -22,6 +24,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitMod.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitMod.lean index f83e7cca8a..176f3d0f8b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitMod.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitMod.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymAlg /-! # Module powers over the unit monoid @@ -18,6 +20,8 @@ multiplication law inherited — the substrate of the local splitting algebra. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitSimple.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitSimple.lean index 3572f5818b..01b860a35c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitSimple.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitSimple.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Definitions +module + +public import LeanPool.RegtsSevenster.RS.Definitions /-! # Simplicity of the tensor unit @@ -26,6 +28,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitStage.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitStage.lean index 58d0bc6ab0..201b5433ec 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitStage.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UnitStage.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ScalarLinear /-! # Stage detection for maps out of the unit @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UniversalAlgebra.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UniversalAlgebra.lean index f6df02f104..f866827430 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/UniversalAlgebra.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/UniversalAlgebra.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.CommonAlgebra -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitTransport +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.CommonAlgebra +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SplitTransport /-! # The universal algebra of Deligne 2.11 @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/WhiskerFaithful.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/WhiskerFaithful.lean index a3b917d125..9ceab00fa8 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/WhiskerFaithful.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/WhiskerFaithful.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorExact +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast /-! # Whiskering by a nonzero object is faithful @@ -21,6 +23,8 @@ Simplicity of the unit is carried as a hypothesis and discharged where `End 𝟙 = ℂ` is available. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/WordMap.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/WordMap.lean index fa1422dd9b..43f85d9a4a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/WordMap.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/WordMap.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodPow +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BiprodPow /-! # Word maps of an arbitrary pair of morphisms @@ -34,6 +36,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZagAction.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZagAction.lean index 1ed63f1b36..7c74003e3b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZagAction.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZagAction.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.BraidCoherence -import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorDatum +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.BraidCoherence +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.TensorDatum /-! # Paired left actions and the joint action @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagCarrier.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagCarrier.lean index 39b48844fd..d814019e7f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagCarrier.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagCarrier.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma /-! # Carrier-level zigzag identities @@ -34,6 +36,8 @@ conversely. the multi-level laws from the carrier-level identities. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagNonzero.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagNonzero.lean index fad306aae6..313148923a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagNonzero.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagNonzero.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.KeyLemma /-! # Nonvanishing detection from the zigzag laws @@ -24,6 +26,8 @@ nonvanishing exactly from the nonvanishing of the corresponding power objects. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagSandwich.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagSandwich.lean index e8ba529b40..3ee322a6bb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagSandwich.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagSandwich.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.SandwichRetract +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier /-! # The zigzag laws as a sandwich retract @@ -22,6 +24,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransfer.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransfer.lean index 327de1bb3e..28bee4fbda 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransfer.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransfer.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagCarrier -import LeanPool.RegtsSevenster.RS.Classical.Deligne.SymDatum -import LeanPool.RegtsSevenster.RS.Classical.Deligne.PairPerm +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 @@ -21,6 +23,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransferIso.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransferIso.lean index f89f255b29..c7da3c653d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransferIso.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ZigzagTransferIso.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransfer +module + +public import LeanPool.RegtsSevenster.RS.Classical.Deligne.ZigzagTransfer /-! # Transport of the zigzag laws along isomorphisms @@ -15,6 +17,8 @@ transfer is vacuous and the zigzag laws pass across without any further hypothesis. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Limits diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneBridge.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneBridge.lean index 2e425c6e3c..0362e3b3d0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneBridge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneBridge.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.FibreTransport -import LeanPool.RegtsSevenster.RS.Novel.Extraction.SnakeTransport +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 @@ -19,6 +21,8 @@ supersymmetry by the braided-functor axiom, and `exists_std_model` produces the coordinates. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackage.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackage.lean index e98ebcfc9c..07a925c74b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackage.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackage.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.SuperVect +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.SuperVect /-! # The Deligne fibre-functor interface @@ -25,6 +27,8 @@ cited theorem are discharged for that envelope in `RS/Novel/Envelope/EnvDelignePackage.lean`. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackageRestrict.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackageRestrict.lean index 1e8bc56554..8dc691b7ea 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackageRestrict.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DelignePackageRestrict.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage /-! # Restriction of Deligne packages @@ -14,6 +16,8 @@ monoidal, additive, ℂ-linear functor: compose the fibre functor with the embedding. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneTheorem.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneTheorem.lean index 2d080c83cc..f838277915 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneTheorem.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/DeligneTheorem.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Growth +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Growth /-! # Deligne's theorem on tensor categories @@ -27,6 +29,8 @@ representations of a supergroup, which yields the functor by composing with the forgetful functor. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.Limits MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/EulerianIndependence.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/EulerianIndependence.lean index e41cd34a5c..f60be41f7b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/EulerianIndependence.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/EulerianIndependence.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition /-! # The Eulerian-independence interface @@ -18,6 +20,8 @@ eliminates the choice in `EdgeSubset.mixedValue` against any concrete transition data. -/ +@[expose] public section + namespace RS /-- The Eulerian-independence statement (Regts–Sevenster, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/FibreTransport.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/FibreTransport.lean index 301d56b58b..45c97d80f3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/FibreTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/FibreTransport.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Monoidal functors preserve exact pairings @@ -22,6 +24,8 @@ monoidal functor) is Mathlib's `ExactPairing.ofFaithful`. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Category diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/KoszulAction.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/KoszulAction.lean index f63588d897..67db1071e2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/KoszulAction.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/KoszulAction.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaTensorPower +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaTensorPower /-! # The even-component restriction of the super permutation action @@ -20,6 +22,8 @@ representation kills too. That containment is what the sector trace needs. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaPerm.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaPerm.lean index fc3bc4d1b7..72263580ae 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaPerm.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackage -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.FibreTransport -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower -import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance +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 @@ -45,6 +47,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaTensorPower.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaTensorPower.lean index cf99a48f84..23f8bf0516 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaTensorPower.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/OmegaTensorPower.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaPerm -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower +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 @@ -36,6 +38,8 @@ This file builds the chain: by `omegaPow`. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SchurPackage.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SchurPackage.lean index bbf3a93fdb..a4e843f1fe 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SchurPackage.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SchurPackage.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams -import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums +module + +public import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums /-! # The symmetric-group Schur interface @@ -32,6 +34,8 @@ constructed from mathlib's linear algebra as `RS.schurPackage` in `RS/Classical/SchurTheory/Package.lean`. -/ +@[expose] public section + namespace RS universe u diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorDischarge.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorDischarge.lean index 0913a6ad04..ad7794212e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorDischarge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorDischarge.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorIntertwine -import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialDet -import LeanPool.RegtsSevenster.RS.QuantSector +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 @@ -30,6 +32,8 @@ standard-model extraction `(e, e')`, then feeds the sector traces * `squareSectorBound_of_detPos` — the last gap of the quantitative theorem. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorIntertwine.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorIntertwine.lean index 4bbd88a80d..199e20a59b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorIntertwine.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorIntertwine.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.KoszulAction -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorNonvanishing -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord +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 @@ -49,6 +51,8 @@ follows from `superPermAction_zero_imp_evenPermRep_zero` in `KoszulAction.lean`. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/TotalDimension.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/TotalDimension.lean index 9c8630c91e..cd2023f3bf 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/TotalDimension.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/TotalDimension.lean @@ -4,12 +4,14 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.ExponentialGrowth -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.WordCommutant -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourTotal -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaTensorPower -import LeanPool.RegtsSevenster.RS.Novel.Envelope.Frobenius -import LeanPool.RegtsSevenster.RS.Novel.Envelope.RankDimension +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 @@ -21,6 +23,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BlockKill.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BlockKill.lean index fcfe4a84be..1ec785c12e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BlockKill.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BlockKill.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.KillSimples +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.KillSimples /-! # Kill criteria for the block development @@ -14,6 +16,8 @@ intertwiners commute with the whole algebra action, so annihilation transports along equivalences of representations. -/ +@[expose] public section + namespace RS open Finset LinearMap diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BranchTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BranchTrace.lean index 61f09121fa..e02fff86aa 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BranchTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/BranchTrace.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly /-! # Branching from the restriction pairing @@ -16,6 +18,8 @@ identity, and compute the trace of the cast idempotent as the pairing. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CentralElem.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CentralElem.lean index 9cc4c2dfbc..bbe2e40884 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CentralElem.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CentralElem.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.RegularTrace +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.RegularTrace /-! # Class functions give central elements @@ -14,6 +16,8 @@ coefficient function is central — pure coefficient algebra, no representation theory. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharClass.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharClass.lean index 05f28846a5..0f0c3dd752 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharClass.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharClass.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTChar +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTChar /-! # Class-function properties of the colour and Jacobi–Trudi @@ -15,6 +17,8 @@ under inversion (a permutation is conjugate to its inverse, having the same cycle type). -/ +@[expose] public section + namespace RS open Finset Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharDecomp.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharDecomp.lean index 65d5fc67da..44f2d8618d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharDecomp.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharDecomp.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharEquiv -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SimpleEmbed +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharEquiv +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SimpleEmbed /-! # Character decomposition into native characters @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharEquiv.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharEquiv.lean index d52530201f..0ddba300d7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharEquiv.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CharEquiv.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable /-! # Character invariance under representation equivalence @@ -15,6 +17,8 @@ group element. The corollary specialises this to the native submodule representations `rhoS`. -/ +@[expose] public section + namespace RS open Finset LinearMap diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourCycleSum.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourCycleSum.lean index c82b9e346c..9fd5a5c03c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourCycleSum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourCycleSum.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharClass -import LeanPool.RegtsSevenster.RS.Common.PermCongr -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SigmaCycleType +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 @@ -17,6 +19,8 @@ and the Frobenius formula for the Jacobi–Trudi character hold unconditionally. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourWeight.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourWeight.lean index 8cad2d9cf4..dcd061ee0f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourWeight.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ColourWeight.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ContentCount -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.StabCount +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ContentCount +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.StabCount /-! # Colour classes of prescribed composition @@ -18,6 +20,8 @@ weighted permutation sum as a sum of stabilizer weights over the class. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CommutantBound.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CommutantBound.lean index a7b918ec55..4fc5c32d8a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CommutantBound.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CommutantBound.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharDecomp -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharDecomp +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful /-! # Dimension bounds through the commutant @@ -17,6 +19,8 @@ faithfulness, and the commutant dimension bounds the number of simple summands, counted with multiplicity. -/ +@[expose] public section + namespace RS open Finset LinearMap Representation diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ContentCount.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ContentCount.lean index b7e29d6ffb..6d10ba8996 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ContentCount.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ContentCount.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FibreCard +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FibreCard /-! # Content-grouped counting identity @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleFactor.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleFactor.lean index 82478d13a5..9373d9a82b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleFactor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleFactor.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SameCycleQuot +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SameCycleQuot /-! # The orbit factorization of a fixed-colouring sum @@ -15,6 +17,8 @@ each orbit is coloured uniformly, contributing a power sum in its size. -/ +@[expose] public section + namespace RS open Finset Equiv Equiv.Perm diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSum.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSum.lean index f4eeb92823..6a240419ab 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSum.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSumPrep -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.OrbitBridge -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.StabCount -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ContentCount +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) @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSumPrep.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSumPrep.lean index 034163cae3..18683ffb95 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSumPrep.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/CycleSumPrep.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleFactor +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleFactor /-! # Preparation for the cycle-sum identity @@ -15,6 +17,8 @@ cycle-sum identity from realized power sums to arbitrary prospective ones. -/ +@[expose] public section + namespace RS open Finset Equiv Equiv.Perm diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/EndSum.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/EndSum.lean index e94451c5a4..320684ff40 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/EndSum.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/EndSum.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj /-! # Constructive simplicity of endomorphism algebras @@ -15,6 +17,8 @@ generates the full endomorphism algebra in the sense that it can be `U i`, `W i` such that `∑ i, U i * A * W i = 1`. -/ +@[expose] public section + namespace RS open Module in diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FibreCard.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FibreCard.lean index 7bcaf87fc4..1e37699367 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FibreCard.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FibreCard.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj /-! # Fibres of a colouring @@ -13,6 +15,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FixWeight.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FixWeight.lean index 476377da6a..01552e6181 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FixWeight.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/FixWeight.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSum +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CycleSum /-! # Weighted stabilizer factorization @@ -19,6 +21,8 @@ additivity over `sigmaCongrRight`) enter as explicit hypotheses, discharged in `ColourCycleSum.lean`. -/ +@[expose] public section + namespace RS open Finset Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/HVal.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/HVal.lean index 9653c1948c..1df76e74e7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/HVal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/HVal.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums /-! # Evaluated symmetric values and the power–complete Newton identity @@ -23,6 +25,8 @@ unit of multiplicity. Consequently `hVal x` satisfies the defining recursion of `newtonH (pVal x)`. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/IdempotentBridge.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/IdempotentBridge.lean index 6e98c253f2..962f609d8a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/IdempotentBridge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/IdempotentBridge.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage /-! # The interface idempotent as a class element @@ -16,6 +18,8 @@ normalizations agree, identifying `charIdempotent (nDim S) (nChar S)` with `nProjector S` over the symmetric group. -/ +@[expose] public section + namespace RS open Finset Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTChar.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTChar.lean index 91a3133f2c..40fdf19a90 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTChar.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTChar.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FixWeight -import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FixWeight +public import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams /-! # The Jacobi–Trudi virtual character @@ -20,6 +22,8 @@ cycle sum. The two cycle-type transport facts enter as explicit hypotheses, discharged in `ColourCycleSum.lean`. -/ +@[expose] public section + namespace RS open Finset Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIntChar.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIntChar.lean index 91b6f173f7..a1174cc767 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIntChar.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIntChar.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharDecomp -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PermModule +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 @@ -17,6 +19,8 @@ sum yields `jtChar μ` as a signed combination of native characters with signs in `{±1}`. -/ +@[expose] public section + namespace RS open Finset Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIrreducible.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIrreducible.lean index e249b021cf..adde1ee38a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIrreducible.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTIrreducible.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTOrtho -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharEquiv -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharClass +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 @@ -18,6 +20,8 @@ squares over the classes, and conclude a unique class with coefficient `±1`. -/ +@[expose] public section + namespace RS open Finset Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTOrtho.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTOrtho.lean index 20d0aa77be..eff762f6c1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTOrtho.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTOrtho.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairChar -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairTuple -import LeanPool.RegtsSevenster.RS.Classical.SymFun.TCount -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTChar +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 @@ -17,6 +19,8 @@ product of the symmetric group, which is what makes them the irreducible characters. -/ +@[expose] public section + namespace RS open Finset Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean index cb4e7d5c6b..7098ca2f54 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTChar +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTChar /-! # Zero-row padding for the Jacobi–Trudi character @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTSimple.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTSimple.lean index 232f589af7..b3ebda5bac 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTSimple.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTSimple.lean @@ -4,13 +4,17 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIntChar -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTIrreducible +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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/KillSimples.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/KillSimples.lean index 9c211c43b0..a1017d9912 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/KillSimples.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/KillSimples.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ScalarTrace +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ScalarTrace /-! # The faithfulness trick @@ -16,6 +18,8 @@ of elements of simples, and left multiplication kills each summand. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedCount.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedCount.lean index 0370af7729..dcb2b31251 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedCount.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedCount.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedFixed -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedFixed +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight /-! # Mixed fixed-point convolution @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedFixed.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedFixed.lean index c39f1e7f9e..f7a627eaa3 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedFixed.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/MixedFixed.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FibreCard +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FibreCard /-! # Mixed fixed-point decomposition @@ -14,6 +16,8 @@ Decomposes the subtype of colourings fixed by a lifted permutation on the first `m` coordinates and free colourings on the tail. -/ +@[expose] public section + namespace RS open Finset Equiv.Perm Fin diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeAction.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeAction.lean index 04158d6dce..cb11fa6f3f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeAction.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeAction.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BlockKill -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.EndSum +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BlockKill +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.EndSum /-! # The native simple-submodule representation @@ -17,6 +19,8 @@ definitionally scalar multiplication, so no transparency options and no equivalence transport are needed. -/ +@[expose] public section + namespace RS open Finset LinearMap diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeFaithful.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeFaithful.lean index 663d4b9482..557d93ba90 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeFaithful.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeFaithful.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable /-! # Native block faithfulness @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeTable.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeTable.lean index 0a2ec6c49f..09d503ab55 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeTable.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/NativeTable.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeAction +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeAction /-! # The native projector and its action table @@ -15,6 +17,8 @@ orthogonality-evaluated action table, idempotency, centrality, and the block rank. -/ +@[expose] public section + namespace RS open Finset LinearMap diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/OrbitBridge.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/OrbitBridge.lean index 7990209db9..b3bc086152 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/OrbitBridge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/OrbitBridge.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SameCycleQuot +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SameCycleQuot /-! # Orbit-size multiset identity @@ -13,6 +15,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/Package.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/Package.lean index d6caa93717..80180e7a13 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/Package.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/Package.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairingPos -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTPad -import LeanPool.RegtsSevenster.RS.Common.FactorialBound +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 @@ -16,6 +18,8 @@ symmetric-group representation theory consumed by the development is a theorem of this tree. -/ +@[expose] public section + namespace RS open scoped Classical in diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PackageAssembly.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PackageAssembly.lean index 6b2ad83e3c..f41505f83b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PackageAssembly.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PackageAssembly.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowth -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.IdempotentBridge -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeFaithful +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 @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairChar.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairChar.lean index 09edc8fb90..e82ca23c7b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairChar.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairChar.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight /-! # The colour character of a pair @@ -14,6 +16,8 @@ character of a pair of colourings is the product of the two characters at the same permutation. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairInner.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairInner.lean index 43da40dbcb..b31385ba9e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairInner.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairInner.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairOrbit +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairOrbit /-! # The pair-colouring count with margins @@ -15,6 +17,8 @@ pair contents with those margins: Fubini, the pair stabilizer count, content grouping, and orbit–stabilizer. -/ +@[expose] public section + namespace RS open Finset Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairOrbit.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairOrbit.lean index 93800c1119..01a96c82d1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairOrbit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairOrbit.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairStab +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairStab /-! # Orbit–stabilizer for pair colourings @@ -14,6 +16,8 @@ classes (transported along `finProdFinEquiv`), and the fibre-margin partition. -/ +@[expose] public section + namespace RS open Finset Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairStab.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairStab.lean index 7f00adb184..4baac7d506 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairStab.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairStab.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourWeight /-! # Stabilizer counts for pair colourings @@ -13,6 +15,8 @@ The stabilizer count for colourings by pairs, transported along `finProdFinEquiv` from the `Fin`-codomain machinery. -/ +@[expose] public section + namespace RS open Finset Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairTuple.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairTuple.lean index 92115cdc06..684fa5f80b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairTuple.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairTuple.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairInner +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PairInner /-! # Pair-content to tuple equivalence @@ -13,6 +15,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean index 97291dd9bc..3340546546 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PairingPos.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.BranchTrace -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.MixedCount -import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffSplit -import LeanPool.RegtsSevenster.RS.Classical.SymFun.PieriChain +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 @@ -17,6 +19,8 @@ bridging the combinatorial Pieri chain to the representation-theoretic branching sandwich. -/ +@[expose] public section + namespace RS open Finset MvPolynomial Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PermModule.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PermModule.lean index b1d85b8006..0e58eb929f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PermModule.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PermModule.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharClass +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CharClass /-! # The permutation module on a colour class @@ -15,6 +17,8 @@ with the inverse. The resulting `ofMulAction` representation has character equal to `colourChar α`. -/ +@[expose] public section + namespace RS open Finset Equiv MonoidAlgebra diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PowerSurj.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PowerSurj.lean index 7c402b3d8e..a4c93b4183 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PowerSurj.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/PowerSurj.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.HVal +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.HVal /-! # Surjectivity of the power-sum specialization @@ -22,6 +24,8 @@ identities are proved for genuine variable families and transferred to arbitrary prospective power sums. -/ +@[expose] public section + namespace RS open Finset Polynomial diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/RegularTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/RegularTrace.lean index f957b92422..b013633d69 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/RegularTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/RegularTrace.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj /-! # The trace of left multiplication on a group algebra @@ -15,6 +17,8 @@ idempotents this computes block dimensions without any decomposition theory. -/ +@[expose] public section + namespace RS open Finset LinearMap Module diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SameCycleQuot.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SameCycleQuot.lean index 8d0b01cee5..1dc621f30e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SameCycleQuot.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SameCycleQuot.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PowerSurj /-! # The same-cycle quotient of a permutation @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ScalarTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ScalarTrace.lean index 2a77ce7364..2d1c69202d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ScalarTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/ScalarTrace.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SchurAction +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SchurAction /-! # Identifying the Schur scalar by its trace @@ -14,6 +16,8 @@ irreducible representation is determined by the character pairing: `z · dim V = ∑ g, c g · χ_ρ(g)`. -/ +@[expose] public section + namespace RS open Finset LinearMap diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SchurAction.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SchurAction.lean index 51fed9b0c9..159e2c1ff6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SchurAction.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SchurAction.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CentralElem +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CentralElem /-! # Schur scalarity for commuting endomorphisms @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SigmaCycleType.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SigmaCycleType.lean index c3dca70f13..4a15243a4d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SigmaCycleType.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SigmaCycleType.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # The cycle type of a fibrewise permutation @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignResolve.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignResolve.lean index 3ab9eee8dd..a0664de6e5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignResolve.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignResolve.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.DimFormula -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTSimple +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.DimFormula +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.JTSimple /-! # The sign resolution @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean index 31ad3a6694..116f6dbee9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorTrace -import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialH -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PackageAssembly +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 @@ -16,6 +18,8 @@ signed Frobenius sum expressing the twisted trace in terms of Schur values at the negated sequence. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean index ad94d64dbf..27b0890e4e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.NativeTable /-! # Every simple module embeds in the regular module @@ -13,6 +15,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowth.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowth.lean index a20d9ec113..caaf180561 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowth.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowth.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareStair +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareStair /-! # The square dimension growth @@ -17,6 +19,8 @@ most `(2s)^(s²)` times it, so the dimension dominates the hypothesis `H3`, discharged in `FactorialBound.lean`. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowthSharp.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowthSharp.lean index edee162a6f..8fe22a6ae5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowthSharp.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareGrowthSharp.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowth +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowth /-! # Sharp square dimension growth via the exponential bound @@ -16,6 +18,8 @@ analytic `n ^ n ≤ e ^ n · n !` (one term of the Taylor series of displayed `2e` of the paper. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareStair.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareStair.lean index 9d0fbbb877..7411eb4be1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareStair.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SquareStair.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignResolve +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignResolve /-! # The natural dimension identity and square staircases @@ -15,6 +17,8 @@ diagrams, and the elementary factorial bounds feeding the square growth estimate. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/StabCount.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/StabCount.lean index 41e5675235..bde32e9bbc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/StabCount.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/StabCount.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FibreCard +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.FibreCard /-! # Stabiliser count for colourings @@ -13,6 +15,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorNonvanishing.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorNonvanishing.lean index f9979547c7..aed38a4f8a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorNonvanishing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorNonvanishing.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignedTensor +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SignedTensor /-! # Nonvanishing of idempotent images from Schur values @@ -19,6 +21,8 @@ nonzero — the even and odd sectors of the dimension-bound dichotomy. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorTrace.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorTrace.lean index bcae3c4eed..a9e78cd99e 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/TensorTrace.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PermModule +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.PermModule /-! # The tensor-space permutation representation and its character @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/WordCommutant.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/WordCommutant.lean index 979b6f980c..e9b2b3cbeb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/WordCommutant.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/WordCommutant.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CommutantBound +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.CommutantBound /-! # Polynomial commutant bounds for monomial word actions @@ -16,6 +18,8 @@ lies between zero and the word length, giving the polynomial bound `(n + 1) ^ (Fintype.card α ^ 2)`. -/ +@[expose] public section + namespace RS open Finset Representation diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourAction.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourAction.lean index 67efeea492..c132c9f12f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourAction.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourAction.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjTop -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjStep +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjTop +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConjStep /-! # The colour action of the model braidings @@ -15,6 +17,8 @@ braiding acts on the colouring model as the Koszul-signed adjacent swap, positionwise and wordwise. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConj.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConj.lean index 858b244dd9..debd26e91f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConj.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConj.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.PowBraid -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourEval +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.PowBraid +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourEval /-! # Conjugation into the colouring model @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjStep.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjStep.lean index cd786f0653..83d11c5af7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjStep.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjStep.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConj +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConj /-! # Step compatibility of the colouring conjugation @@ -16,6 +18,8 @@ observing that the `tensorCongr`-conjugation of a whisker is `tensorHom` of the inner conjugation. -/ +@[expose] public section + open scoped TensorProduct namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean index acdac815c1..b3cb6ec419 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TwoBasis -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TopBraidMerge +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 @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourEval.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourEval.lean index 4e74b25903..d5c1ee1074 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourEval.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourEval.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower /-! # Evaluating a colour tensor @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourExtendSwap.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourExtendSwap.lean index 5bccdb5aa1..862e6d0ab0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourExtendSwap.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourExtendSwap.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConj +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConj /-! # Extension commutes with an adjacent colour swap @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourFormMatch.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourFormMatch.lean index 2890a82059..fb56550da6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourFormMatch.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourFormMatch.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairing +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairing /-! # The colour form entries are the standard form @@ -16,6 +18,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMerge.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMerge.lean index efb5ce7162..8398a1ec20 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMerge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMerge.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourEval +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourEval /-! # The merge coordinate product rule @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean index 178a75bc0b..e7fa070063 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMerge +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMerge /-! # The merge coordinate product rule, odd input @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairing.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairing.lean index 88c02f8406..d4b5fb1af5 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairing.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower /-! # The tensor-power pairing in colouring coordinates @@ -19,6 +21,8 @@ single-position form entries: `1` on matching even colours, the symplectic entry on odd colours, `0` on mixed positions. -/ +@[expose] public section + namespace RS /-- The single-position form entry: Kronecker on even colours, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairingSymm.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairingSymm.lean index bb4973d01a..a7d345f23a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairingSymm.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPairingSymm.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairing +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPairing /-! # S_d-invariance of the pinned pairing (Lemma 5.1(b)) @@ -27,6 +29,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPower.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPower.lean index e9060f598d..54b2aef2ce 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPower.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourPower.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper +module + +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper /-! # The colouring model of tensor powers @@ -21,6 +23,8 @@ meshing directly with the mixed partition function's Definition-5 sum. -/ +@[expose] public section + open scoped TensorProduct namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourTotal.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourTotal.lean index 7633be120b..0a899c2dc2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourTotal.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourTotal.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.TotalSpace -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.TotalSpace +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord /-! # The total colouring coordinates @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourWord.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourWord.lean index 8b6cd058fb..9af087fa60 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourWord.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourWord.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourExtendSwap -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BraidWord +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourExtendSwap +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BraidWord /-! # The colour-side braiding word @@ -17,6 +19,8 @@ word's Koszul sign, computed stepwise along the colouring's own trajectory. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/OrthonormalBasis.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/OrthonormalBasis.lean index 9354001a2c..4197d8845a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/OrthonormalBasis.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/OrthonormalBasis.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Orthonormal basis for nondegenerate symmetric bilinear @@ -28,6 +30,8 @@ The proof proceeds by: diagonal entries to `1`. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/PowBraid.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/PowBraid.lean index afddcc6bcd..581b5206c9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/PowBraid.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/PowBraid.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower /-! # Adjacent braidings on monoidal powers @@ -17,6 +19,8 @@ defined here; the identification is the coordinate workhorse of the extraction. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/SuperVect.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/SuperVect.lean index aebbf16ae8..596d746dbf 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/SuperVect.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/SuperVect.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Definitions +module + +public import LeanPool.RegtsSevenster.RS.Definitions /-! # Unit-prefixed associator and braiding values in SuperVect @@ -19,6 +21,8 @@ blocks, and the braiding on the four generator shapes, including the Koszul sign on odd⊗odd. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/SymplecticBasis.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/SymplecticBasis.lean index beeff49bbc..f8266e3dee 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/SymplecticBasis.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/SymplecticBasis.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Symplectic structure of alternating nondegenerate bilinear forms @@ -29,6 +31,8 @@ through `Basis.prod`, `Submodule.prodEquivOfIsCompl` and the reindexing `symplecticReindexEquiv` on `Fin (2 * ℓ)`. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/TotalSpace.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/TotalSpace.lean index 7810f57def..e706254a53 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/TotalSpace.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/TotalSpace.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.SuperVect +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.SuperVect /-! # Total spaces of super vector spaces @@ -14,6 +16,8 @@ components. Morphisms act componentwise, giving an algebra map on endomorphisms. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/WordSignPerm.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/WordSignPerm.lean index b67840c278..f01784ab35 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/WordSignPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/WordSignPerm.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord /-! # Word sign depends only on the word's permutation @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantExpand.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantExpand.lean index 2be2a9ea35..56a16026ba 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantExpand.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantExpand.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffExtract +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffExtract /-! # Coefficients against the staircase alternant @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantPieri.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantPieri.lean index e257dd46db..f192b6ec44 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantPieri.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantPieri.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffExtract +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffExtract /-! # Pieri rule for plain alternants @@ -20,6 +22,8 @@ via `det_apply'`, use the per-term product identity for match termwise. -/ +@[expose] public section + namespace RS open Finset MvPolynomial Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantStrict.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantStrict.lean index f773c5fdae..3e5f5bd735 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantStrict.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/AlternantStrict.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantPieri +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantPieri /-! # Coefficients of strict alternants @@ -15,6 +17,8 @@ is the equality indicator — the two facts driving nonnegativity in the Pieri chain. -/ +@[expose] public section + namespace RS open Finset MvPolynomial Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/Bialternant.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/Bialternant.lean index 392faf5313..c8461c3a22 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/Bialternant.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/Bialternant.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHDischarge +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHDischarge /-! # The bialternant Jacobi–Trudi identity @@ -20,6 +22,8 @@ determinants and anchoring at `v = 0` gives the bialternant form: the polynomial Jacobi–Trudi identity `a_{v+δ} = s_v · a_δ`. -/ +@[expose] public section + namespace RS open Finset MvPolynomial Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialDet.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialDet.lean index 1ddb376608..af4248bf92 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialDet.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialDet.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialH -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareStair +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 @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialH.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialH.lean index db00303e35..610d90bf38 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialH.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/BinomialH.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums /-! # Complete homogeneous values at constant sequences @@ -16,6 +18,8 @@ function `(1−z)^{−m}`); at `−m` they are the signed binomials the tensor-space traces of the dimension-bound argument. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffExtract.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffExtract.lean index 65c8f527c4..2cf40467e2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffExtract.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffExtract.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.Bialternant +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.Bialternant /-! # Coefficient extraction from alternants @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffSplit.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffSplit.lean index 17a6012b1e..69f8007d1d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/CoeffSplit.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowCount +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowCount /-! # The pointwise convolution form of product coefficients @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/DeltaSeq.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DeltaSeq.lean index bca2ce1d06..64b736694d 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/DeltaSeq.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DeltaSeq.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourCycleSum +module + +public import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.ColourCycleSum /-! # The delta power-sum sequence @@ -16,6 +18,8 @@ Jacobi–Trudi character degree as `n!` times the Jacobi–Trudi determinant at `t₀`. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/DescVandermonde.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DescVandermonde.lean index d295514bce..741add5359 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/DescVandermonde.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DescVandermonde.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Determinant of the descending-Pochhammer evaluation matrix @@ -19,6 +21,8 @@ the descending Pochhammer polynomials (which are monic of the correct degree) combined with `det_vandermonde`. -/ +@[expose] public section + open Polynomial Matrix Finset namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/DimFormula.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DimFormula.lean index 18c8690302..60bb291e62 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/DimFormula.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/DimFormula.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.DeltaSeq -import LeanPool.RegtsSevenster.RS.Classical.SymFun.DescVandermonde +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.DeltaSeq +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.DescVandermonde /-! # The exact dimension determinant @@ -17,6 +19,8 @@ and evaluates the determinant as a manifestly positive Vandermonde product of staircase differences. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/EHConv.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/EHConv.lean index a74edf1e7d..94808dac2f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/EHConv.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/EHConv.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.SubsetEH +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SubsetEH /-! # The e–h convolution and the single-variable resolvent @@ -17,6 +19,8 @@ add-one-variable recurrence enters as the hypothesis `HSubRec`, discharged in `HInsert.lean`. -/ +@[expose] public section + namespace RS open Finset MvPolynomial diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/EHDischarge.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/EHDischarge.lean index a9041041a2..c8cd8e51ed 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/EHDischarge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/EHDischarge.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.HInsert -import LeanPool.RegtsSevenster.RS.Classical.SymFun.HSubZ +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HInsert +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HSubZ /-! # Discharge of the `hSub` recurrence hypothesis @@ -16,6 +18,8 @@ so the resolvent identity and the shifted forms hold unconditionally. -/ +@[expose] public section + namespace RS /-- The add-one-variable recurrence, discharging the hypothesis the diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HInsert.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HInsert.lean index 014e95ffc7..6be2c3e6d9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HInsert.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HInsert.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.SubsetEH +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SubsetEH /-! # The add-one-variable recurrence for `hSub` @@ -12,6 +14,8 @@ import LeanPool.RegtsSevenster.RS.Classical.SymFun.SubsetEH `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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HProdCoeff.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HProdCoeff.lean index 6134248416..0c7180702b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HProdCoeff.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HProdCoeff.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffExtract +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.CoeffExtract /-! # Coefficient of a product of complete homogeneous polynomials @@ -14,6 +16,8 @@ The coefficient of a monomial `w` in the product symmetric-function indices whose combined weight equals `w`. -/ +@[expose] public section + namespace RS open Finset MvPolynomial diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HSubZ.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HSubZ.lean index 4accf9b297..eefb707bd0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HSubZ.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HSubZ.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHConv +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.EHConv /-! # Integer-indexed complete homogeneous polynomials @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HookVanishing.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HookVanishing.lean index e55d5f1596..705610613b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/HookVanishing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/HookVanishing.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams -import LeanPool.RegtsSevenster.RS.Classical.SymFun.RecurrenceFromVanishing -import LeanPool.RegtsSevenster.RS.Classical.SymFun.RationalityFromRecurrence +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 @@ -23,6 +25,8 @@ This is the composition of `exists_recurrence_of_schurDet_vanishing` of `Common/YoungDiagrams.lean`. -/ +@[expose] public section + namespace RS /-- **Lemma A.9**: if the Schur specialization of `t` vanishes on diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTDetExpand.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTDetExpand.lean index d90256cb43..337995f633 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTDetExpand.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTDetExpand.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantExpand +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantExpand /-! # Leibniz expansion of the Jacobi–Trudi determinant @@ -14,6 +16,8 @@ permutations of complete homogeneous products, with terms containing a negative degree vanishing. -/ +@[expose] public section + namespace RS open Finset MvPolynomial Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTGuard.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTGuard.lean index 0fbfc812b3..6fc748222b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTGuard.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/JTGuard.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.TIdentity +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.TIdentity /-! # Guard and margin bridges for the double-sum identity @@ -15,6 +17,8 @@ margins match the shifted compositions, and sorted shapes have injective staircase exponents. -/ +@[expose] public section + namespace RS open Finset Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/LGVStrict.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/LGVStrict.lean index 84eeb931ba..67ea8d8371 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/LGVStrict.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/LGVStrict.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialDet +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.BinomialDet /-! # Nonvanishing of the binomial Toeplitz determinant @@ -22,6 +24,8 @@ noncrossing tuples all have `σ = 1` and count with sign `+1`, and at least one exists. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/PieriChain.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PieriChain.lean index 550e4eb48f..14be82d871 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/PieriChain.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PieriChain.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.AlternantStrict -import LeanPool.RegtsSevenster.RS.Common.RowLenChain +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 @@ -15,6 +17,8 @@ coefficient of the target monomial in `p₁ʳ · a_{eVec λ}` when `μ` extends `λ` by `r` cells. -/ +@[expose] public section + namespace RS open Finset MvPolynomial Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowCount.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowCount.lean index d2d67697c8..fdd04e2abb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowCount.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowCount.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.HProdCoeff +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HProdCoeff /-! # Coefficient of a power of p₁ @@ -13,6 +15,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowerSums.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowerSums.lean index 4c5f299c93..c1eb4ea523 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowerSums.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/PowerSums.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Power sums and the determinant Schur specialization @@ -23,6 +25,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/RationalityFromRecurrence.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RationalityFromRecurrence.lean index 0ea17f205b..d63a326ea6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/RationalityFromRecurrence.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RationalityFromRecurrence.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums /-! # Rationality from recurrence @@ -21,6 +23,8 @@ 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⟧`); diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/RecurrenceFromVanishing.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RecurrenceFromVanishing.lean index e756766966..95e2c620a2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/RecurrenceFromVanishing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RecurrenceFromVanishing.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums /-! # Recurrence from Schur-determinant vanishing @@ -32,6 +34,8 @@ The proof proceeds in three stages: recurrence. -/ +@[expose] public section + namespace RS open Finset Matrix Submodule Module diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/SubsetEH.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/SubsetEH.lean index 427420e69b..8ec075ad4c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/SubsetEH.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/SubsetEH.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Subset-indexed elementary and complete homogeneous polynomials @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/SuperPowerSums.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/SuperPowerSums.lean index f70386bb95..abf7b546c7 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/SuperPowerSums.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/SuperPowerSums.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.PowerSums /-! # Super power sums @@ -22,6 +24,8 @@ the shifted power-sum series; this is immediate from the Newton recursion that defines `newtonH`. -/ +@[expose] public section + namespace RS open Finset PowerSeries diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/TCount.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/TCount.lean index b6e584c943..241b0a0bba 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/TCount.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/TCount.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTGuard -import LeanPool.RegtsSevenster.RS.Classical.SymFun.HProdCoeff +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 @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/TIdentity.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/TIdentity.lean index e697a74049..d1f385db88 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/TIdentity.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/TIdentity.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTDetExpand +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.JTDetExpand /-! # The signed double-sum identity @@ -16,6 +18,8 @@ products equals `1`. This is the polynomial form of the orthonormality `⟨χ_μ, χ_μ⟩ = 1`. -/ +@[expose] public section + namespace RS open Finset MvPolynomial Equiv diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaExp.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaExp.lean index 58258b93fe..e3ad408657 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaExp.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaExp.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaSeries +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaSeries /-! # The trace zeta function in exponential form @@ -15,6 +17,8 @@ via the differential characterization — the displayed form of the trace zeta function. -/ +@[expose] public section + namespace RS open PowerSeries diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaRational.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaRational.lean index 0fcc058b61..cb0f30ec96 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaRational.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaRational.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.HookVanishing +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HookVanishing /-! # Rationality of the Newton generating series @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaSeries.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaSeries.lean index c9eb1a7ed5..3445495454 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaSeries.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaSeries.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums +module + +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.SuperPowerSums /-! # Zeta series characterization @@ -17,6 +19,8 @@ for formal power series over ℂ and applies it to characterize the Newton series. -/ +@[expose] public section + namespace RS open Finset PowerSeries diff --git a/LeanPool/RegtsSevenster/RS/Common.lean b/LeanPool/RegtsSevenster/RS/Common.lean index 16fe291f30..0304daf722 100644 --- a/LeanPool/RegtsSevenster/RS/Common.lean +++ b/LeanPool/RegtsSevenster/RS/Common.lean @@ -4,21 +4,23 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.NilpotentMap -import LeanPool.RegtsSevenster.RS.Common.ListPairs -import LeanPool.RegtsSevenster.RS.Common.FinSlots -import LeanPool.RegtsSevenster.RS.Common.DiagramChain -import LeanPool.RegtsSevenster.RS.Common.ExponentialGrowth -import LeanPool.RegtsSevenster.RS.Common.FactorialBound -import LeanPool.RegtsSevenster.RS.Common.ListAttach -import LeanPool.RegtsSevenster.RS.Common.ListSign -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps -import LeanPool.RegtsSevenster.RS.Common.NilpotentPowerTrace -import LeanPool.RegtsSevenster.RS.Common.PairDisjoint -import LeanPool.RegtsSevenster.RS.Common.PermCongr -import LeanPool.RegtsSevenster.RS.Common.PermTopSplit -import LeanPool.RegtsSevenster.RS.Common.ProdSum -import LeanPool.RegtsSevenster.RS.Common.RowLenChain -import LeanPool.RegtsSevenster.RS.Common.RowSpanRank -import LeanPool.RegtsSevenster.RS.Common.TraceSeparation -import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams +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 index 4d3a64009c..09b61ef8c9 100644 --- a/LeanPool/RegtsSevenster/RS/Common/DiagramChain.lean +++ b/LeanPool/RegtsSevenster/RS/Common/DiagramChain.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams +module + +public import LeanPool.RegtsSevenster.RS.Common.YoungDiagrams /-! # Single-box interpolation for Young diagrams @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Common/ExponentialGrowth.lean b/LeanPool/RegtsSevenster/RS/Common/ExponentialGrowth.lean index c5a6629e68..c555274d77 100644 --- a/LeanPool/RegtsSevenster/RS/Common/ExponentialGrowth.lean +++ b/LeanPool/RegtsSevenster/RS/Common/ExponentialGrowth.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Comparing exponential bases with polynomial factors @@ -13,6 +15,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Common/FactorialBound.lean b/LeanPool/RegtsSevenster/RS/Common/FactorialBound.lean index 9fcac64292..aa37707669 100644 --- a/LeanPool/RegtsSevenster/RS/Common/FactorialBound.lean +++ b/LeanPool/RegtsSevenster/RS/Common/FactorialBound.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # `n ^ n ≤ 3 ^ n · n !` @@ -27,6 +29,8 @@ which the `⌊2eR⌋` threshold does need, is `RS/Classical/SchurTheory/SquareGrowthSharp.lean`. -/ +@[expose] public section + namespace RS open Finset Nat diff --git a/LeanPool/RegtsSevenster/RS/Common/FinSlots.lean b/LeanPool/RegtsSevenster/RS/Common/FinSlots.lean index 41df74ff29..d748e16820 100644 --- a/LeanPool/RegtsSevenster/RS/Common/FinSlots.lean +++ b/LeanPool/RegtsSevenster/RS/Common/FinSlots.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Disjoint halves of a finite index set @@ -13,6 +15,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Common/ListAttach.lean b/LeanPool/RegtsSevenster/RS/Common/ListAttach.lean index 6e666749df..52af24efd8 100644 --- a/LeanPool/RegtsSevenster/RS/Common/ListAttach.lean +++ b/LeanPool/RegtsSevenster/RS/Common/ListAttach.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Attached lists and list-to-finset products @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Common/ListPairs.lean b/LeanPool/RegtsSevenster/RS/Common/ListPairs.lean index 8d1ad77da3..d5533b32de 100644 --- a/LeanPool/RegtsSevenster/RS/Common/ListPairs.lean +++ b/LeanPool/RegtsSevenster/RS/Common/ListPairs.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Length and indexing of concatenated pairs @@ -13,6 +15,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Common/ListSign.lean b/LeanPool/RegtsSevenster/RS/Common/ListSign.lean index 68b31cc676..8e8877aa13 100644 --- a/LeanPool/RegtsSevenster/RS/Common/ListSign.lean +++ b/LeanPool/RegtsSevenster/RS/Common/ListSign.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Definitions +module + +public import LeanPool.RegtsSevenster.RS.Definitions /-! # Inversions and the sorting sign @@ -16,6 +18,8 @@ combinatorial engine of the alternating evaluation of mixed vertex functionals. -/ +@[expose] public section + namespace RS /-- Sorting signs square to one over ℂ. -/ diff --git a/LeanPool/RegtsSevenster/RS/Common/MathlibDeps.lean b/LeanPool/RegtsSevenster/RS/Common/MathlibDeps.lean index 0d85e294e2..58c95b1cc2 100644 --- a/LeanPool/RegtsSevenster/RS/Common/MathlibDeps.lean +++ b/LeanPool/RegtsSevenster/RS/Common/MathlibDeps.lean @@ -4,129 +4,131 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import Mathlib.Algebra.Algebra.Subalgebra.Lattice -import Mathlib.Algebra.BigOperators.Fin -import Mathlib.Algebra.Category.FGModuleCat.Abelian -import Mathlib.Algebra.Category.ModuleCat.Biproducts -import Mathlib.Algebra.DirectSum.LinearMap -import Mathlib.Algebra.Group.Even -import Mathlib.Algebra.Homology.ShortComplex.ExactFunctor -import Mathlib.Algebra.Homology.ShortComplex.ShortExact -import Mathlib.Algebra.Module.PUnit -import Mathlib.Algebra.MonoidAlgebra.Basic -import Mathlib.Algebra.MonoidAlgebra.Module -import Mathlib.Analysis.Complex.Cardinality -import Mathlib.Analysis.Complex.Polynomial.Basic -import Mathlib.Analysis.SpecialFunctions.Exp -import Mathlib.CategoryTheory.Abelian.Basic -import Mathlib.CategoryTheory.Abelian.FunctorCategory -import Mathlib.CategoryTheory.Abelian.GrothendieckAxioms.Colim -import Mathlib.CategoryTheory.Abelian.GrothendieckAxioms.Indization -import Mathlib.CategoryTheory.Abelian.Indization -import Mathlib.CategoryTheory.Abelian.Transfer -import Mathlib.CategoryTheory.Filtered.Connected -import Mathlib.CategoryTheory.Functor.OfSequence -import Mathlib.CategoryTheory.Generator.Indization -import Mathlib.CategoryTheory.Idempotents.Biproducts -import Mathlib.CategoryTheory.Idempotents.Karoubi -import Mathlib.CategoryTheory.Limits.Indization.Category -import Mathlib.CategoryTheory.Limits.Shapes.Biproducts -import Mathlib.CategoryTheory.Limits.Shapes.End -import Mathlib.CategoryTheory.Linear.LinearFunctor -import Mathlib.CategoryTheory.Monoidal.Braided.Basic -import Mathlib.CategoryTheory.Monoidal.Braided.Opposite -import Mathlib.CategoryTheory.Monoidal.Braided.Transport -import Mathlib.CategoryTheory.Monoidal.Category -import Mathlib.CategoryTheory.Monoidal.Closed.Braided -import Mathlib.CategoryTheory.Monoidal.Closed.Types -import Mathlib.CategoryTheory.Monoidal.CommMon_ -import Mathlib.CategoryTheory.Monoidal.DayConvolution.Braided -import Mathlib.CategoryTheory.Monoidal.DayConvolution.DayFunctor -import Mathlib.CategoryTheory.Monoidal.Functor -import Mathlib.CategoryTheory.Monoidal.Linear -import Mathlib.CategoryTheory.Monoidal.Mod -import Mathlib.CategoryTheory.Monoidal.Mon -import Mathlib.CategoryTheory.Monoidal.Preadditive -import Mathlib.CategoryTheory.Monoidal.Rigid.Basic -import Mathlib.CategoryTheory.Monoidal.Rigid.Braided -import Mathlib.CategoryTheory.Monoidal.Subcategory -import Mathlib.CategoryTheory.Monoidal.Transport -import Mathlib.CategoryTheory.Preadditive.Mat -import Mathlib.CategoryTheory.Preadditive.Schur -import Mathlib.CategoryTheory.Simple -import Mathlib.CategoryTheory.Subobject.Lattice -import Mathlib.CategoryTheory.Subobject.Limits -import Mathlib.Combinatorics.Enumerative.Partition.Basic -import Mathlib.Combinatorics.Young.YoungDiagram -import Mathlib.Basic.Complex.Basic -import Mathlib.Data.Fin.Embedding -import Mathlib.Data.Fin.Tuple.Sort -import Mathlib.Data.Finset.Card -import Mathlib.Data.Finset.Lattice.Basic -import Mathlib.Data.Finset.NoncommProd -import Mathlib.Data.Fintype.EquivFin -import Mathlib.Data.Fintype.Perm -import Mathlib.FieldTheory.IsAlgClosed.Basic -import Mathlib.GroupTheory.Perm.Cycle.Basic -import Mathlib.GroupTheory.Perm.Cycle.Type -import Mathlib.GroupTheory.Perm.Fin -import Mathlib.GroupTheory.Perm.ViaEmbedding -import Mathlib.LinearAlgebra.Basis.VectorSpace -import Mathlib.LinearAlgebra.BilinearForm.Basic -import Mathlib.LinearAlgebra.BilinearForm.Orthogonal -import Mathlib.LinearAlgebra.BilinearForm.Properties -import Mathlib.LinearAlgebra.Contraction -import Mathlib.LinearAlgebra.DFinsupp -import Mathlib.LinearAlgebra.Dimension.Constructions -import Mathlib.LinearAlgebra.Dimension.Finrank -import Mathlib.LinearAlgebra.Dimension.Free -import Mathlib.LinearAlgebra.Dimension.StrongRankCondition -import Mathlib.LinearAlgebra.Dual.Lemmas -import Mathlib.LinearAlgebra.Eigenspace.Basic -import Mathlib.LinearAlgebra.Eigenspace.Triangularizable -import Mathlib.LinearAlgebra.FiniteDimensional.Defs -import Mathlib.LinearAlgebra.FiniteDimensional.Lemmas -import Mathlib.LinearAlgebra.Isomorphisms -import Mathlib.LinearAlgebra.LinearIndependent.Lemmas -import Mathlib.LinearAlgebra.Matrix.Determinant.Basic -import Mathlib.LinearAlgebra.Matrix.NonsingularInverse -import Mathlib.LinearAlgebra.Matrix.Rank -import Mathlib.LinearAlgebra.Matrix.ToLin -import Mathlib.LinearAlgebra.Prod -import Mathlib.LinearAlgebra.Projection -import Mathlib.LinearAlgebra.QuadraticForm.Basic -import Mathlib.LinearAlgebra.TensorProduct.Associator -import Mathlib.LinearAlgebra.TensorProduct.Finiteness -import Mathlib.LinearAlgebra.TensorProduct.Prod -import Mathlib.LinearAlgebra.Trace -import Mathlib.LinearAlgebra.Vandermonde -import Mathlib.Logic.Equiv.Fin.Rotate -import Mathlib.Order.Zorn -import Mathlib.RepresentationTheory.Basic -import Mathlib.RepresentationTheory.Character -import Mathlib.RepresentationTheory.Irreducible -import Mathlib.RepresentationTheory.Maschke -import Mathlib.RingTheory.Algebraic.LinearIndependent -import Mathlib.RingTheory.Artinian.Module -import Mathlib.RingTheory.Artinian.Ring -import Mathlib.RingTheory.EuclideanDomain -import Mathlib.RingTheory.Finiteness.Prod -import Mathlib.RingTheory.Ideal.Quotient.Operations -import Mathlib.RingTheory.Idempotents -import Mathlib.RingTheory.Jacobson.Ring -import Mathlib.RingTheory.Jacobson.Semiprimary -import Mathlib.RingTheory.MvPolynomial.Symmetric.NewtonIdentities -import Mathlib.RingTheory.Polynomial.Vieta -import Mathlib.RingTheory.PowerSeries.Derivative -import Mathlib.RingTheory.PowerSeries.Exp -import Mathlib.RingTheory.PowerSeries.Inverse -import Mathlib.RingTheory.PowerSeries.Substitution -import Mathlib.RingTheory.SimpleModule.Basic -import Mathlib.RingTheory.SimpleModule.IsAlgClosed -import Mathlib.RingTheory.TensorProduct.Finite -import Mathlib.SetTheory.Cardinal.Order -import Mathlib.Tactic.CategoryTheory.Monoidal.Basic -import Mathlib.Tactic.CategoryTheory.Slice +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 diff --git a/LeanPool/RegtsSevenster/RS/Common/NilpotentMap.lean b/LeanPool/RegtsSevenster/RS/Common/NilpotentMap.lean index 2adf27e2a7..8c4bee16ef 100644 --- a/LeanPool/RegtsSevenster/RS/Common/NilpotentMap.lean +++ b/LeanPool/RegtsSevenster/RS/Common/NilpotentMap.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Nilpotence under zero-preserving multiplicative maps @@ -13,6 +15,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Common/NilpotentPowerTrace.lean b/LeanPool/RegtsSevenster/RS/Common/NilpotentPowerTrace.lean index 5fee0f8fac..3e11ae9976 100644 --- a/LeanPool/RegtsSevenster/RS/Common/NilpotentPowerTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Common/NilpotentPowerTrace.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # A last nonzero power trace @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Common/PairDisjoint.lean b/LeanPool/RegtsSevenster/RS/Common/PairDisjoint.lean index e6f2c83d3b..e9163df9c7 100644 --- a/LeanPool/RegtsSevenster/RS/Common/PairDisjoint.lean +++ b/LeanPool/RegtsSevenster/RS/Common/PairDisjoint.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Label pairs sharing no label @@ -18,6 +20,8 @@ fields, so that the four inequalities are never read off a nested conjunction by position. -/ +@[expose] public section + namespace RS variable {α : Type*} diff --git a/LeanPool/RegtsSevenster/RS/Common/PermCongr.lean b/LeanPool/RegtsSevenster/RS/Common/PermCongr.lean index acd04a17f1..13db12575c 100644 --- a/LeanPool/RegtsSevenster/RS/Common/PermCongr.lean +++ b/LeanPool/RegtsSevenster/RS/Common/PermCongr.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Cycle data under permutation transport @@ -20,6 +22,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Common/PermTopSplit.lean b/LeanPool/RegtsSevenster/RS/Common/PermTopSplit.lean index 031d39f5eb..f55ca997c7 100644 --- a/LeanPool/RegtsSevenster/RS/Common/PermTopSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Common/PermTopSplit.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Splitting a permutation at the top slot @@ -21,6 +23,8 @@ induced permutation is not the one a tensor power's factors see. The compression here is `finSuccAboveEquiv`. -/ +@[expose] public section + namespace RS open Equiv diff --git a/LeanPool/RegtsSevenster/RS/Common/ProdSum.lean b/LeanPool/RegtsSevenster/RS/Common/ProdSum.lean index b1fb03b97d..eb390a586a 100644 --- a/LeanPool/RegtsSevenster/RS/Common/ProdSum.lean +++ b/LeanPool/RegtsSevenster/RS/Common/ProdSum.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Sums through linear maps and into a product @@ -20,6 +22,8 @@ live here rather than beside their first user because two files need them. -/ +@[expose] public section + namespace RS variable {M N A B ι κ : Type*} diff --git a/LeanPool/RegtsSevenster/RS/Common/RowLenChain.lean b/LeanPool/RegtsSevenster/RS/Common/RowLenChain.lean index 2c9c4920a1..73d2864ed0 100644 --- a/LeanPool/RegtsSevenster/RS/Common/RowLenChain.lean +++ b/LeanPool/RegtsSevenster/RS/Common/RowLenChain.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.DiagramChain +module + +public import LeanPool.RegtsSevenster.RS.Common.DiagramChain /-! # Row lengths along single-box extensions @@ -13,6 +15,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Common/RowSpanRank.lean b/LeanPool/RegtsSevenster/RS/Common/RowSpanRank.lean index 79cd1dbc15..7c3b23693d 100644 --- a/LeanPool/RegtsSevenster/RS/Common/RowSpanRank.lean +++ b/LeanPool/RegtsSevenster/RS/Common/RowSpanRank.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # The row span of a matrix over arbitrary index types @@ -27,6 +29,8 @@ on `κ` is separated by finitely many coordinates infinite matrix visible on a single finite submatrix. -/ +@[expose] public section + namespace RS variable {K : Type*} diff --git a/LeanPool/RegtsSevenster/RS/Common/TraceSeparation.lean b/LeanPool/RegtsSevenster/RS/Common/TraceSeparation.lean index 2f5217a6ef..adc7d3ce79 100644 --- a/LeanPool/RegtsSevenster/RS/Common/TraceSeparation.lean +++ b/LeanPool/RegtsSevenster/RS/Common/TraceSeparation.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Linear independence from a trace supported at the identity @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Common/YoungDiagrams.lean b/LeanPool/RegtsSevenster/RS/Common/YoungDiagrams.lean index 1fb5a35f0f..0f64a82333 100644 --- a/LeanPool/RegtsSevenster/RS/Common/YoungDiagrams.lean +++ b/LeanPool/RegtsSevenster/RS/Common/YoungDiagrams.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Young diagram helpers @@ -16,6 +18,8 @@ square diagram is the shape whose dimension growth drives that confinement. -/ +@[expose] public section + namespace RS /-- The `s × s` square Young diagram. -/ diff --git a/LeanPool/RegtsSevenster/RS/Definitions.lean b/LeanPool/RegtsSevenster/RS/Definitions.lean index 869518a448..4406adca3e 100644 --- a/LeanPool/RegtsSevenster/RS/Definitions.lean +++ b/LeanPool/RegtsSevenster/RS/Definitions.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # The statement surface, defined @@ -18,7 +20,9 @@ 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 +public import list with no content), so its meaning is determined by this file + +@[expose] public section 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` diff --git a/LeanPool/RegtsSevenster/RS/DimensionDefinitions.lean b/LeanPool/RegtsSevenster/RS/DimensionDefinitions.lean index a50343df56..fcf08ced8f 100644 --- a/LeanPool/RegtsSevenster/RS/DimensionDefinitions.lean +++ b/LeanPool/RegtsSevenster/RS/DimensionDefinitions.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Definitions +module + +public import LeanPool.RegtsSevenster.RS.Definitions /-! # Connection ranks and minimum colour dimension @@ -16,6 +18,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Glossary.lean b/LeanPool/RegtsSevenster/RS/Glossary.lean index 664b59f99d..1dcd525567 100644 --- a/LeanPool/RegtsSevenster/RS/Glossary.lean +++ b/LeanPool/RegtsSevenster/RS/Glossary.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Glossary diff --git a/LeanPool/RegtsSevenster/RS/Novel.lean b/LeanPool/RegtsSevenster/RS/Novel.lean index 10552fc40b..02abea341f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel.lean +++ b/LeanPool/RegtsSevenster/RS/Novel.lean @@ -4,336 +4,338 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairList -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjSwapBmc -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjacentWord -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisCoord -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisSplit -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaData -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiag -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiagForm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaFlip -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockCanon -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockOddList -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockParity -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockRestrict -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSigma -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSort -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BraidWord -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonColour -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapClosed -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapExpansion -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapFun -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapMatch -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeel -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeelSplit -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapSplit -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapVal -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ChainLists -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleModel -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleScalar -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircuitCount -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ClosedTransition -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ConcatSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordInterface -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordOf -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoreParity -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EdgeSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvForm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvFormOdd -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvLeaf -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FibreParam -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FlagEnum -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.GlobalSlotList -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.HRS -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ListSignPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MasterSum -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelCoord -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelStarVec -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MultiStar -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFDef -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFValue -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddFlip -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddListMultiset -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddPair -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddSignProd -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaCotensor -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTensor -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTransport -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OneBasis -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OrbitCard -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OutSignEdges -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairEnum -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ParameterModel -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PatternInv -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RegroupSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.Reindex -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexHeart -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexVanish -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RiffleSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SignPair -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SkeinPowBraid -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SlotPairing -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortFactor -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarClassFactor -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPeel -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarRepeat -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarSymm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarTensorClass -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StdTransport -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StrandTransport -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauCount -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TopBraidMerge -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TwoBasis -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue -import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomDichotomy -import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomicIdempotents -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockAssembly -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockBounds -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockCycle -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactor -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactorialTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockSplice -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockTower -import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleNormal -import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvAbelian -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDeligne -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDelignePackage -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGenerator -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGrowth -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvSemisimple -import LeanPool.RegtsSevenster.RS.Novel.Envelope.FactorialTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.Frobenius -import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement -import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinementSharp -import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiEmbBraided -import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiMonoidal -import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiRigid -import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiSemisimple -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatBraided -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatEmbMonoidal -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatMonoidal -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatRigid -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatSemisimple -import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentMatTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.ObjectTower -import LeanPool.RegtsSevenster.RS.Novel.Envelope.PermTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarPermTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleAll -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleEnd -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinDimBound -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SuperKill -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast -import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowHom -import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowSplit -import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZeta -import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZetaSharp -import LeanPool.RegtsSevenster.RS.Novel.Extraction.CircleValue -import LeanPool.RegtsSevenster.RS.Novel.Extraction.CoordIso -import LeanPool.RegtsSevenster.RS.Novel.Extraction.Coordinates -import LeanPool.RegtsSevenster.RS.Novel.Extraction.CopairUnique -import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate -import LeanPool.RegtsSevenster.RS.Novel.Extraction.SnakeTransport -import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdDuality -import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid -import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper -import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalAgreement -import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalIndependence -import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedNat -import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleClose -import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleMapClasses -import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleTensor -import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence -import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonTransport -import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonicalFrame -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChainAgreement -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordCount -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordParity -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordSwapParity -import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate -import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotateLeft -import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseUnion -import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedAgreement -import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedCutDispatch -import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedIdentify -import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedTopSum -import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourGlue -import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourRecursion -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeNormal -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeRelabel -import LeanPool.RegtsSevenster.RS.Novel.Skein.Composition -import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseAssembly -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseFamily -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseGram -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseIdentity -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseLift -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConversePair -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseTrip -import LeanPool.RegtsSevenster.RS.Novel.Skein.CrossingDelta -import LeanPool.RegtsSevenster.RS.Novel.Skein.CutMatching -import LeanPool.RegtsSevenster.RS.Novel.Skein.CutSubsetSum -import LeanPool.RegtsSevenster.RS.Novel.Skein.DirMatching -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjSubsetSplit -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.A -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.B -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.C -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionProduct -import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeColouring -import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeSum -import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeTerm -import LeanPool.RegtsSevenster.RS.Novel.Skein.Eulerian -import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.FibreValue -import LeanPool.RegtsSevenster.RS.Novel.Skein.FlagGraph -import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignForm -import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignProduct -import LeanPool.RegtsSevenster.RS.Novel.Skein.FourLabelParity -import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv -import LeanPool.RegtsSevenster.RS.Novel.Skein.GenBoundaryStates -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueAmbient -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChord -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChords -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCircuitDelta -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueComm -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueLedger -import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueRelTransport -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplit -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.A -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.C -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSubsetBij -import LeanPool.RegtsSevenster.RS.Novel.Skein.GramRank -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomCompose -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomSpaces -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceCyclic -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate -import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw -import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceAlternate -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceContract -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceCut -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceOrderIso -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceShift -import LeanPool.RegtsSevenster.RS.Novel.Skein.InvolutionCard -import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords -import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerCast -import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerRecursion -import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerSets -import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerStage -import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerValue -import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopExample -import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopVerify -import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition -import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalNat -import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalStruct -import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity -import LeanPool.RegtsSevenster.RS.Novel.Skein.NonSeparatedStep -import LeanPool.RegtsSevenster.RS.Novel.Skein.OpenCircuits -import LeanPool.RegtsSevenster.RS.Novel.Skein.OrbitParities -import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientExistence -import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientationFlip -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairCloseComm -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairedAssembly -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSwap -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingValue -import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialClose -import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseCompose -import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseTensor -import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon -import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger -import LeanPool.RegtsSevenster.RS.Novel.Skein.PathMatch -import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose -import LeanPool.RegtsSevenster.RS.Novel.Skein.PermFragment -import LeanPool.RegtsSevenster.RS.Novel.Skein.PropThreeOpen -import LeanPool.RegtsSevenster.RS.Novel.Skein.RSTensor -import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition -import LeanPool.RegtsSevenster.RS.Novel.Skein.RelValue -import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelChords -import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelInvariance -import LeanPool.RegtsSevenster.RS.Novel.Skein.RepairInvariance -import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidityClasses -import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarClass -import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarFunctional -import LeanPool.RegtsSevenster.RS.Novel.Skein.SeparatedParity -import LeanPool.RegtsSevenster.RS.Novel.Skein.SimpleUnit -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCategory -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdealLeft -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinLinear -import LeanPool.RegtsSevenster.RS.Novel.Skein.SnakeClasses -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarCompClass -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarDecomposition -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarEnum -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarExplode -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarPrep -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarTrace -import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet -import LeanPool.RegtsSevenster.RS.Novel.Skein.StatusSet -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepFrame -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatus -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatusNonsep -import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle -import LeanPool.RegtsSevenster.RS.Novel.Skein.SumLexOrder -import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperGram -import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperSpace -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorAssoc -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorComm -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorCompClass -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorInterchange -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorUnit -import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut -import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughIndCFalse -import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue -import LeanPool.RegtsSevenster.RS.Novel.Skein.Trace -import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic -import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceNondegenerate -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionMove -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger -import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathNonSep -import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathStep -import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexOddSign -import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexSum -import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourEmbedding -import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourPadding -import LeanPool.RegtsSevenster.RS.Novel.Envelope.RankDimension +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 index dadcb02a93..9b2b8d7f35 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjSwapBmc.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjSwapBmc.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SkeinPowBraid -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjacentWord +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SkeinPowBraid +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjacentWord /-! # The skein braiding as a bundle map @@ -17,6 +19,8 @@ transpose, so the whole recursion lives in the bundle-map calculus. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjacentWord.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjacentWord.lean index 3015d4f0aa..e5d87819a8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjacentWord.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjacentWord.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Adjacent-transposition words for permutations of `Fin n` @@ -26,6 +28,8 @@ conjugation identity and lift the recursive word for `σ'` by mapping positions through `Fin.succ`. -/ +@[expose] public section + namespace RS open Equiv diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisCoord.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisCoord.lean index 5bd0bb14e6..7b48d9f2c0 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisCoord.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisCoord.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordOf -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisSplit +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordOf +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisSplit /-! # Coordinates of basis vectors @@ -14,6 +16,8 @@ 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 ℓ : ℕ} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisSplit.lean index 6a8b954802..88465a4720 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisSplit.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMergeOdd +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMergeOdd /-! # Basis vectors split over the merge @@ -16,6 +18,8 @@ both parities identify the coordinates; injectivity does the rest. -/ +@[expose] public section + namespace RS open scoped TensorProduct diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaData.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaData.lean index fa068eb60e..6e2acc9616 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaData.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaData.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij /-! # The `β`-diagonal's colour data @@ -13,6 +15,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiag.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiag.lean index 8dbe5ce604..d5050916d4 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiag.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiag.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeelSplit -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisCoord +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeelSplit +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisCoord /-! # The diagonal cap pairing @@ -16,6 +18,8 @@ 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 ℓ : ℕ} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiagForm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiagForm.lean index fa9b3c1a27..24a160d279 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiagForm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiagForm.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiag -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord +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 @@ -15,6 +17,8 @@ The diagonal cap pairing `betaDiag m c` on a colouring pairing `betaColour` applied to the two halves of `c`. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaFlip.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaFlip.lean index 2c51e38530..29b7ec69f4 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaFlip.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaFlip.lean @@ -4,11 +4,13 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaData -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EdgeSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddSignProd -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OutSignEdges -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign +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 @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockAlign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockAlign.lean index 55b4c89a36..77a27e87bc 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockAlign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockAlign.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddFlip +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 @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockCanon.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockCanon.lean index 54cdefa193..54669d7e42 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockCanon.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockCanon.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddListMultiset +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 @@ -17,6 +19,8 @@ multiset at the block's vertex, and the odd list carries the Definition 5 odd values. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockData.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockData.lean index ebb3107961..7c3ac34c06 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockData.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockData.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij /-! # Block data of the data colouring @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockOddList.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockOddList.lean index ad93d819bc..d19c554208 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockOddList.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockOddList.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FlagEnum +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FlagEnum /-! # The block odd list, order-exactly @@ -15,6 +17,8 @@ Definition 5 value map over the block-slot flag enumeration, entry by entry. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockParity.lean index 3e830636de..25074d9f20 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockParity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockParity.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.Reindex +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.Reindex /-! # Block parity dictionary @@ -16,6 +18,8 @@ corresponding vertex have even count. Corollary: the master summand vanishes whenever any block is odd-parity. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockRestrict.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockRestrict.lean index 357bb2ca6c..54bf6cf4d2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockRestrict.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockRestrict.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapVal +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourWord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapVal /-! # Block restrictions of colourings @@ -16,6 +18,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSigma.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSigma.lean index 81dbc17530..17bf20000b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSigma.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSigma.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPeel +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPeel /-! # The block sigma equivalence @@ -13,6 +15,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSort.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSort.lean index c7287bf603..22c6dd8074 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSort.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSort.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPeel +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPeel /-! # Sorting a multi-star into blocks @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BraidWord.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BraidWord.lean index c4e0f10f8e..77a847a90f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BraidWord.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BraidWord.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjSwapBmc +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjSwapBmc /-! # Bundle-map permutations through the model transport @@ -15,6 +17,8 @@ any permutation bundle map conjugates through `stdToOmega` into the corresponding word of model braidings. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonColour.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonColour.lean index 97af79ab9b..61b11bfbb1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonColour.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonColour.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarSymm +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarSymm /-! # The canonical colouring of multiset data @@ -16,6 +18,8 @@ vertex functional of Definition 5 evaluates the symmetric star coordinates. -/ +@[expose] public section + namespace RS variable {k ℓ : ℕ} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean index c62e5032bd..ad0554be54 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ListSignPerm +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ListSignPerm /-! # The canonical permutation of colour data @@ -23,6 +25,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapClosed.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapClosed.lean index d6f1d95fe3..bf5ff69d6c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapClosed.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapClosed.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiag +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelPermCoord +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiag /-! # The cap closed form @@ -14,6 +16,8 @@ The peel induction: the cap value on colour basis vectors is the diagonal cap pairing. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapExpansion.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapExpansion.lean index b3066de65f..8d43d44322 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapExpansion.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapExpansion.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvLeaf +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvLeaf /-! # The cap value in coordinates @@ -14,6 +16,8 @@ the cap values of the colour basis vectors: linearity through the coordinate expansion. -/ +@[expose] public section + namespace RS variable {R : ℕ} (f : EdgeRankParameter R) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapFun.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapFun.lean index 974177b0e1..9c0ce3babe 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapFun.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapFun.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeel -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaCotensor +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPeel +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaCotensor /-! # The cap functional recursion @@ -16,6 +18,8 @@ successor cap evaluates through the peel rotation and the tensor split. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapMatch.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapMatch.lean index 8d997c4c5e..9935925fc5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapMatch.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapMatch.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BraidWord +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BraidWord /-! # Towards the matching cap @@ -16,6 +18,8 @@ into the strand-bundle cap yields the cap of the permuted matching. -/ +@[expose] public section + namespace RS variable {R : ℕ} (f : EdgeRankParameter R) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeel.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeel.lean index c2e75b1c65..98c5f4270c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeel.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeel.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapMatch +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapMatch /-! # Peeling the bundle cap @@ -16,6 +18,8 @@ boundary word. This is the recursion that computes the cap functional in coordinates. -/ +@[expose] public section + namespace RS /-- The peel rotation, on values. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeelSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeelSplit.lean index f269e2c6d5..04be7056d8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeelSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeelSplit.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapExpansion +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapExpansion /-! # The peel step in model form @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPerm.lean index 2292486d2d..13b08a0ebf 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPerm.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvForm +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvForm /-! # The peel rotation as a permutation and a cast @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapSplit.lean index cf82cc7b4d..5a971b8b14 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapSplit.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelCoord +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelCoord /-! # The split cap on merged vectors @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapVal.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapVal.lean index 9c32f9a4d7..66022f9ea1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapVal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapVal.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordOf +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordOf /-! # The cap value on model vectors @@ -14,6 +16,8 @@ final computation evaluates. Its base case: the zero cap reads off the scalar itself. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ChainLists.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ChainLists.lean index 4ebb0efdea..a46c461a2f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ChainLists.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ChainLists.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.GlobalSlotList +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.GlobalSlotList /-! # The chain enumerations @@ -14,6 +16,8 @@ edge-interleaved list, the oriented list, the matched list, and the global pair concatenation. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleModel.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleModel.lean index f591853d9c..f4076c05f7 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleModel.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleModel.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StdTransport -import LeanPool.RegtsSevenster.RS.Novel.Extraction.CircleValue +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StdTransport +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CircleValue /-! # The circle value in the model @@ -18,6 +20,8 @@ and the standard model identifies it with the superdimension `k − 2ℓ`. -/ +@[expose] public section + namespace RS open CategoryTheory Functor.LaxMonoidal Functor.OplaxMonoidal diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleScalar.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleScalar.lean index d0d1261a97..b0db9df29b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleScalar.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleScalar.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MultiStar -import LeanPool.RegtsSevenster.RS.DimensionDefinitions +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MultiStar +public import LeanPool.RegtsSevenster.RS.DimensionDefinitions /-! # Free circles as scalars @@ -17,6 +19,8 @@ off as the power of the circle value. This is the accompanying paper's class level. -/ +@[expose] public section + namespace RS /-- The circle value of a parameter. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircuitCount.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircuitCount.lean index 3ee81a952b..6382c87860 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircuitCount.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircuitCount.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists /-! # Circuit count decomposition via orientations @@ -17,6 +19,8 @@ restrictions have the same orbit count, whence the circuit count out-restriction. -/ +@[expose] public section + namespace RS open Equiv diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ClosedTransition.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ClosedTransition.lean index a4becd46b0..3a3e7b51a7 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ClosedTransition.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ClosedTransition.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockRestrict -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockRestrict +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists /-! # Transitions on closed fragments @@ -16,6 +18,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ConcatSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ConcatSign.lean index b910643979..c1770355cc 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ConcatSign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ConcatSign.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ChainLists +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ChainLists /-! # Concatenation sign factorisation @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordInterface.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordInterface.lean index 506da59e93..716f0f862f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordInterface.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordInterface.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTransport +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTransport /-! # The coordinate interface @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordOf.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordOf.lean index 0fe6aaddcc..218fe59947 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordOf.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoordOf.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ParameterModel -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConj +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ParameterModel +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourConj /-! # Coordinates of model vectors @@ -16,6 +18,8 @@ basis expansion: the vocabulary in which the final computation evaluates. -/ +@[expose] public section + namespace RS variable {k ℓ : ℕ} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoreParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoreParity.lean index 35554a8efd..b6d0c28bae 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoreParity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoreParity.lean @@ -4,13 +4,15 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaFlip -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauCount -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ConcatSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SignPair -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RiffleSign -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RegroupSign +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 @@ -20,6 +22,8 @@ the parity of the core slots' pairing and the parity of the whole slot list. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Finset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EdgeSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EdgeSign.lean index 8bbe3fd356..784e86885f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EdgeSign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EdgeSign.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddFlip +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddFlip /-! # The edge-sign sector @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvForm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvForm.lean index f171b4d9f2..8a85966728 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvForm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvForm.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapFun +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapFun /-! # The evaluation functional in standard coordinates @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvFormOdd.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvFormOdd.lean index f55cf9de9d..0c1474257d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvFormOdd.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvFormOdd.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisSplit -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddPair +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BasisSplit +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddPair /-! # The evaluation functional on odd pairs @@ -16,6 +18,8 @@ structure map is the standard form's odd block — the symplectic entries. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvLeaf.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvLeaf.lean index 8f99648894..7b80aa51b0 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvLeaf.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvLeaf.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OneBasis +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OneBasis /-! # The evaluation leaf @@ -16,6 +18,8 @@ evenness; the pure branches route through the one-position basis presentations and the standard-form identification. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FibreParam.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FibreParam.lean index 6c41339807..dde38840d3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FibreParam.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FibreParam.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.Reindex +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.Reindex /-! # The fibre parametrization @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FlagEnum.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FlagEnum.lean index 579219ce21..ec3bb04182 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FlagEnum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FlagEnum.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairEnum -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairEnum +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData /-! # The two flag enumerations @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/GlobalSlotList.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/GlobalSlotList.lean index c6bac7ba31..11e4d0b003 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/GlobalSlotList.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/GlobalSlotList.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PatternInv +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PatternInv /-! # The global slot list @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/HRS.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/HRS.lean index 00207792a5..e3d2dcd83c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/HRS.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/HRS.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonColour -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourFormMatch +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonColour +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourFormMatch /-! # The Regts–Sevenster functional @@ -19,6 +21,8 @@ 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/IndexPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/IndexPerm.lean index be7d835ee5..59c7efd20c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/IndexPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/IndexPerm.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ListSignPerm +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ListSignPerm /-! # The index permutation between two orderings of the same list @@ -17,6 +19,8 @@ any injective relabelling differ by exactly it, and the sign is multiplicative along a chain of reorderings. -/ +@[expose] public section + namespace RS open Equiv diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ListSignPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ListSignPerm.lean index 8a7b64be71..08d10330a8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ListSignPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ListSignPerm.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjacentWord -import LeanPool.RegtsSevenster.RS.Common.ListSign +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.AdjacentWord +public import LeanPool.RegtsSevenster.RS.Common.ListSign /-! # Sorting signs under a permutation of positions @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MasterSum.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MasterSum.lean index 3522a2ceb4..ea81f77a32 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MasterSum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MasterSum.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapClosed +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapClosed /-! # The master colour sum @@ -14,6 +16,8 @@ expansion through the closed form, the permutation and cast transports, and the star-vector coordinates. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelCoord.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelCoord.lean index 64e373a7b3..43fb66d3e4 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelCoord.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelCoord.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourMerge -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ClosedTransition -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.HRS +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 @@ -16,6 +18,8 @@ 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 ℓ : ℕ} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelPermCoord.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelPermCoord.lean index ae323d549b..31c050c53f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelPermCoord.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelPermCoord.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourAction -import LeanPool.RegtsSevenster.RS.Classical.Super.WordSignPerm +module + +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourAction +public import LeanPool.RegtsSevenster.RS.Classical.Super.WordSignPerm /-! # The permutation transport in coordinates @@ -14,6 +16,8 @@ The model permutation map acts on coordinates by the adjacent-word sign and the permutation reindex. -/ +@[expose] public section + open CategoryTheory namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelStarVec.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelStarVec.lean index caffa3895c..25698f2dda 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelStarVec.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelStarVec.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge /-! # The assembled star vector in the model @@ -16,6 +18,8 @@ fibre-side assembled vector. This is the form on which the colouring coordinates evaluate. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MultiStar.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MultiStar.lean index 928f12db00..1780f695c2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MultiStar.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MultiStar.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordInterface +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoordInterface /-! # The multi-star form of the explosion @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFDef.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFDef.lean index ea13af0a0a..9efc2381a3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFDef.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFDef.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockCanon +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockCanon /-! # The h-generic normal form @@ -18,6 +20,8 @@ interface: the normal form is manifestly independent of the transition system and orientation. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFValue.lean index b17a500e54..0cfb489485 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFValue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFValue.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CoreParity -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFDef +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 @@ -15,6 +17,8 @@ summand equals the (κ, o)-free normal form — the engine of Eulerian independence. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddFlip.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddFlip.lean index 443837f72e..9e4d137516 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddFlip.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddFlip.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition /-! # Flipping an odd colouring @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddListMultiset.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddListMultiset.lean index ca01bef6cb..c0373f6ba9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddListMultiset.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddListMultiset.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists /-! # A vertex's odd list, as a multiset @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddPair.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddPair.lean index 07c4bf6cdc..fb961a5a7e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddPair.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddPair.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapSplit +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapSplit /-! # Odd pairs and their vanishing under split functionals @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean index b7d53bb8b0..071e5dea28 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean @@ -4,12 +4,16 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists +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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaCotensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaCotensor.lean index 0a7b95da6f..1ab8debff9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaCotensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaCotensor.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec /-! # Image functionals of tensors @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaStarVec.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaStarVec.lean index 763a39d643..e46c350ef1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaStarVec.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaStarVec.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTensor +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaTensor /-! # The assembled star vector @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean index 01c177d9ca..47b93b8548 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarTensorClass +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarTensorClass /-! # Image vectors of tensors @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTransport.lean index 6fb5c8827f..d3e1401de5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTransport.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarCompClass -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinLinear -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneBridge -import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance +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 @@ -18,6 +20,8 @@ compose to the parameter value times the identity of the image of the unit object. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OneBasis.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OneBasis.lean index d3eab4307d..1119ae75b4 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OneBasis.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OneBasis.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StrandTransport +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StrandTransport /-! # One-position basis vectors @@ -14,6 +16,8 @@ unit-padded standard basis vectors: the single-layer computation of `colourPowerEquiv 1` on padded pure tensors. -/ +@[expose] public section + namespace RS open scoped TensorProduct diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OrbitCard.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OrbitCard.lean index a9772b4538..58bf861f66 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OrbitCard.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OrbitCard.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircuitCount +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircuitCount /-! # The orbit count is the number of orbits @@ -23,6 +25,8 @@ rotation on labels, say — since a bijection of quotients is then enough. -/ +@[expose] public section + namespace RS open Equiv Equiv.Perm diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OutSignEdges.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OutSignEdges.lean index 15ec1fdbab..bdfb3db833 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OutSignEdges.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OutSignEdges.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.RepFlag /-! # Per-edge factoring of the out-sign product @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairEnum.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairEnum.lean index 840b0ebf87..ce0eeb0df9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairEnum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairEnum.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists /-! # The pair enumeration @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairList.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairList.lean index ffc5f90014..1762f1b0db 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairList.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PairList.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ChainLists -import LeanPool.RegtsSevenster.RS.Common.FinSlots +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 @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ParameterModel.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ParameterModel.lean index c22c9eb94e..638b755686 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ParameterModel.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ParameterModel.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortPerm +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortPerm /-! # The parameter value over the model @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PatternInv.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PatternInv.lean index 3b23a391bb..ee79342fa2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PatternInv.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PatternInv.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij /-! # The pattern inversion count @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PowMerge.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PowMerge.lean index be5fa2ce20..bf2a4f1375 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PowMerge.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PowMerge.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonColour +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CanonColour /-! # Merging monoidal powers @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean index 7532cd5998..76905a71b7 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.ListPairs -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairList -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircuitCount +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 @@ -32,6 +34,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/Reindex.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/Reindex.lean index 99404e8797..7f3a09d8ac 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/Reindex.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/Reindex.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarRepeat -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SlotPairing -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence +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 @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexBij.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexBij.lean index 03237d328d..449dce82b6 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexBij.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexBij.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexVanish +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexVanish /-! # The fibre bijection @@ -13,6 +15,8 @@ Closed-pattern fibres are pure; their sums reindex over the colouring data through the diagonal parametrization. -/ +@[expose] public section + namespace RS open CategoryTheory Finset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexHeart.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexHeart.lean index 7a586e9f99..0cc6a5f4db 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexHeart.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexHeart.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.NFValue -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleModel +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 @@ -15,6 +17,8 @@ and the identification of the parameter with Definition 5's mixed partition function. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory Finset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexVanish.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexVanish.lean index ba1c6db041..041557be2d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexVanish.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexVanish.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockParity -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BetaDiagForm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FibreParam +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 @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RepFlag.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RepFlag.lean index bff53bc8f9..8ed4ef545e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RepFlag.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RepFlag.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexBij /-! # Representative flags @@ -16,6 +18,8 @@ the pairing — it is the flip set aligning the data colouring with the Definition 5 odd lists. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RiffleSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RiffleSign.lean index 6ec543e711..ff987bcf9e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RiffleSign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RiffleSign.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairList -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EdgeSign +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PairList +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EdgeSign /-! # The riffle and orientation signs @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SignPair.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SignPair.lean index d935f12da3..a969ff94ff 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SignPair.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SignPair.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.VertexValue /-! # The sign pairing @@ -15,6 +17,8 @@ their mapped sorting signs is the reindexing permutation's sign: the transport plus a square. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SkeinPowBraid.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SkeinPowBraid.lean index db92c6a5f1..9861847d4c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SkeinPowBraid.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SkeinPowBraid.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StdTransport -import LeanPool.RegtsSevenster.RS.Classical.Super.PowBraid +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 @@ -19,6 +21,8 @@ strictness of the skein associator enters only through a small concrete collapse. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SlotPairing.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SlotPairing.lean index 4e21c6a306..6379f9742d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SlotPairing.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SlotPairing.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MultiStar +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MultiStar /-! # The slot pairing @@ -15,6 +17,8 @@ slots `i` and `edgeCount + i`. The general-flag glue for the Eulerian reindex. -/ +@[expose] public section + namespace RS variable {α : Type} (W : ClosedFragment) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortFactor.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortFactor.lean index 9c3e555eb1..1705530cb8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortFactor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortFactor.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSigma -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSort +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSigma +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockSort /-! # The sorted factorization of a multi-star @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortPerm.lean index b240e897d4..8092039536 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SortPerm.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelStarVec +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ModelStarVec /-! # The sort as a permutation and a cast @@ -14,6 +16,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarClassFactor.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarClassFactor.lean index 892575a235..a126cc89d0 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarClassFactor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarClassFactor.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortFactor +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.SortFactor /-! # The class-level star factorization @@ -15,6 +17,8 @@ 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPeel.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPeel.lean index 76a5cf98ad..f2386f519c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPeel.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPeel.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleScalar +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CircleScalar /-! # Peeling the multi-star into vertex stars @@ -15,6 +17,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPerm.lean index ad59723921..04b3d94270 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPerm.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MasterSum +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.MasterSum /-! # Star coordinate symmetry @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarRepeat.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarRepeat.lean index 1521d98a2e..df0384aea1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarRepeat.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarRepeat.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPerm +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarPerm /-! # Fermionic vanishing of star coordinates @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarSymm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarSymm.lean index 7649dcaa8e..27134de5cb 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarSymm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarSymm.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPerm +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.CapPerm /-! # Symmetry of the vertex star @@ -15,6 +17,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarTensorClass.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarTensorClass.lean index ec9ba4e6a6..27ce6170ad 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarTensorClass.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarTensorClass.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarClassFactor +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.StarClassFactor /-! # The star-tensor class and its recursion @@ -15,6 +17,8 @@ tensor of the vertex-star class with the tail, composed with the sum cast. -/ +@[expose] public section + namespace RS variable {R : ℕ} (f : EdgeRankParameter R) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StdTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StdTransport.lean index e7ceab4363..ad2ebda2ef 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StdTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StdTransport.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec -import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OmegaStarVec +public import LeanPool.RegtsSevenster.RS.Classical.Super.ColourPower /-! # The model transport @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StrandTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StrandTransport.lean index 350ab0559c..79cde3a3c3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StrandTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StrandTransport.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvFormOdd +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.EvFormOdd /-! # The one-strand transport collapse @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauCount.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauCount.lean index 93eabb43dc..df5b6599df 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauCount.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauCount.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddListMultiset +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockData +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OddListMultiset /-! # Tau-sign counting lemmas @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauKey.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauKey.lean index 221adee493..33b17757c1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauKey.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TauKey.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.FlagEnum -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.IndexPerm -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockAlign +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 @@ -16,6 +18,8 @@ the canonical index permutation's sign is the key-sortSign of the pair enumeration alone. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TopBraidMerge.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TopBraidMerge.lean index 1cb777838f..92c88efbd1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TopBraidMerge.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TopBraidMerge.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.PowMerge /-! # The top braiding through the merge @@ -15,6 +17,8 @@ merging equals merging and braiding on top. Abstract braided coherence first, instantiated to the powers. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TwoBasis.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TwoBasis.lean index 7663a21be5..b6dd3104a3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TwoBasis.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TwoBasis.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OneBasis +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OneBasis /-! # Two-position basis vectors, raw form @@ -14,6 +16,8 @@ structure `(superPow V 1) ⊗ V`: nested unit-padded standard basis vectors, one lemma per parity pattern. -/ +@[expose] public section + namespace RS open scoped TensorProduct diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexSign.lean index e2d56f7cd8..be5c0d43c6 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexSign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexSign.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockOddList -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockOddList +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.TauKey /-! # The per-vertex sign collapse @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexValue.lean index 2cf8ddfeac..fc5127c4e3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexValue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexValue.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockCanon +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.BlockCanon /-! # The per-vertex value @@ -16,6 +18,8 @@ the canonical colouring, whose star coordinate the functional `hRS` evaluates. -/ +@[expose] public section + namespace RS open CategoryTheory Finset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomDichotomy.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomDichotomy.lean index ba758b08c4..b392cbc417 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomDichotomy.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomDichotomy.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiSemisimple -import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomicIdempotents +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiSemisimple +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomicIdempotents /-! # The Hom-dichotomy between atoms @@ -18,6 +20,8 @@ isomorphism. This is the engine turning the atomic idempotent decomposition into a semisimple-category structure. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.Idempotents diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomicIdempotents.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomicIdempotents.lean index f0fbb189c6..9478a6aa0e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomicIdempotents.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/AtomicIdempotents.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Atomic idempotents in semisimple complex algebras @@ -16,6 +18,8 @@ Wedderburn–Artin. These are the atoms along which Karoubi objects split into simples. -/ +@[expose] public section + namespace RS universe u diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockAssembly.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockAssembly.lean index 4f2cf0e48c..977a5677bd 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockAssembly.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockAssembly.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactor -import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentTrace +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactor +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentTrace /-! # The block Frobenius tower @@ -19,6 +21,8 @@ proof at every strand arity. The mainline semisimplicity proof uses the factorial argument in `BlockFactorialTrace`. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockBounds.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockBounds.lean index ca655b4ada..004efff5dc 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockBounds.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockBounds.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage /-! # Block bounds @@ -18,6 +20,8 @@ containment. Both are stated against an arbitrary target algebra; the skein endomorphism algebras are substituted downstream. -/ +@[expose] public section + namespace RS universe u diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean index 2f03d2f90f..238ea2c6b2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockSplice -import LeanPool.RegtsSevenster.RS.Novel.Envelope.Frobenius -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockTower +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 @@ -23,6 +25,8 @@ into the tuple's cyclic composite, which for a constant tuple is a power. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactor.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactor.lean index 631d2e0c78..e44da33980 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactor.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockCycle +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockCycle /-! # The block trace factorization @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactorialTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactorialTrace.lean index 4ffa7e3d9b..c54edde0ac 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactorialTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactorialTrace.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Algebra.FactorialTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactor -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleEnd +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 @@ -18,6 +20,8 @@ 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockSplice.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockSplice.lean index 80316566d9..e20d8b8f7c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockSplice.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockSplice.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseCompose -import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseUnion +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 @@ -24,6 +26,8 @@ rotation as through-strands tensored with `K` cups, and the same after the outer relabel is collapsed. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockTower.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockTower.lean index 630111bfac..7560c42480 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockTower.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockTower.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower -import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance /-! # The block tower @@ -20,6 +22,8 @@ so the recursive block constructions live at the same indices as the tensor structure. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleNormal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleNormal.lean index 23b6eaae43..8d5a261506 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleNormal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleNormal.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.PermCongr +module + +public import LeanPool.RegtsSevenster.RS.Common.PermCongr /-! # The block-cycle normal form @@ -15,6 +17,8 @@ the normal form against which the skein trace of a permutation factors into cycle loops. -/ +@[expose] public section + namespace RS open Equiv Equiv.Perm diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleTrace.lean index 826e9ca78a..70b9128377 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/CycleTrace.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowHom -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.PartialTrace +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 @@ -24,6 +26,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvAbelian.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvAbelian.lean index 329b52ce64..8377d566ab 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvAbelian.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvAbelian.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentMatTrace +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentMatTrace /-! # The envelope and its regularity @@ -19,6 +21,8 @@ endomorphism algebra, and kernels are the splittings of the regular idempotents. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.Idempotents CategoryTheory.Limits diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDeligne.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDeligne.lean index 504ab2e835..3e53b315c9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDeligne.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDeligne.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LinearCategory -import LeanPool.RegtsSevenster.RS.Novel.Skein.SimpleUnit +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 @@ -23,6 +25,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDelignePackage.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDelignePackage.lean index 68cb66ad73..1c8b4368a6 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDelignePackage.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvDelignePackage.lean @@ -4,15 +4,17 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvSemisimple -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGrowth -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatRigid -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatEmbMonoidal -import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiRigid -import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiEmbBraided -import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidInstance -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DelignePackageRestrict -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.DeligneTheorem +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 @@ -26,6 +28,8 @@ only transcendental input, applied to the concretely constructed envelope. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.Idempotents diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGenerator.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGenerator.lean index 2956941056..e5bd7d79ab 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGenerator.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGenerator.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.TensorPow +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.TensorPow /-! # The strand generator of the envelope @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGrowth.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGrowth.lean index fcb733215d..0798074370 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGrowth.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGrowth.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGenerator -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Growth +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGenerator +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Growth /-! # Moderate growth of the envelope @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvInstances.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvInstances.lean index dccc65159b..1099db8d2b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvInstances.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvInstances.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvAbelian -import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiMonoidal -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatMonoidal +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 @@ -17,6 +19,8 @@ through the Karoubi and matrix layers entrywise, giving the full instance chain for the envelope. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.Idempotents diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvSemisimple.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvSemisimple.lean index 546a2aaeca..256bb4af29 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvSemisimple.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvSemisimple.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDeligne +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDeligne /-! # Semisimplicity of the envelope @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/FactorialTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/FactorialTrace.lean index b50f91b7ff..12e18c63b2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/FactorialTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/FactorialTrace.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Algebra.FactorialTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarPermTrace +module + +public import LeanPool.RegtsSevenster.RS.Classical.Algebra.FactorialTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarPermTrace /-! # Nilpotent categorical traces from the factorial obstruction @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/Frobenius.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/Frobenius.lean index d116d6131a..f45b1d33ee 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/Frobenius.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/Frobenius.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleNormal -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceCyclic -import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedInstance +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 @@ -24,6 +26,8 @@ factorization these feed is `BlockFactor.lean`, and the Frobenius identity itself `BlockAssembly.lean`. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinement.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinement.lean index c90f8ccdf2..369668d3e0 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinement.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinement.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockBounds +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockBounds /-! # Hook confinement @@ -26,6 +28,8 @@ propagation no shape containing the square is alive; and a shape outside the hook contains the square. -/ +@[expose] public section + namespace RS universe u diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinementSharp.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinementSharp.lean index 8563a88dde..e68b59518a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinementSharp.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/HookConfinementSharp.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.SquareGrowthSharp -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.Package +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 @@ -21,6 +23,8 @@ package. The constant here comes from the block dimensions of the assembled package, through `square_growth_sharp`. -/ +@[expose] public section + namespace RS universe u diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiEmbBraided.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiEmbBraided.lean index c01fd970e5..8cc029613e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiEmbBraided.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiEmbBraided.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvInstances /-! # The Karoubi embedding is braided and linear @@ -14,6 +16,8 @@ The canonical functor `toKaroubi C` is a braided monoidal functor the Karoubi envelope) and is ℂ-linear. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.Category CategoryTheory.Idempotents diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiMonoidal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiMonoidal.lean index 3703c77b82..b7eadf57db 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiMonoidal.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Monoidal structure on the Karoubi envelope @@ -25,6 +27,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiRigid.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiRigid.lean index 41c08f3920..8eec1c8969 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiRigid.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiRigid.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiMonoidal +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.KaroubiMonoidal /-! # Rigidity of the Karoubi envelope @@ -21,6 +23,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiSemisimple.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiSemisimple.lean index 0c9cc7e12e..36118054de 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiSemisimple.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiSemisimple.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.KaroubiTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleAll -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactorialTrace +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 @@ -18,6 +20,8 @@ cyclicity moves the idempotent across products, so ambient nondegeneracy restricts to the corner. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.Idempotents diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean index e66aef27f5..31882f97a6 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatMonoidal +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatMonoidal /-! # Braided and symmetric structure on the matrix envelope @@ -14,6 +16,8 @@ When `C` is a braided (resp. symmetric) monoidal preadditive category, so is componentwise braidings of `C`, reindexed by the swap `M.ι × N.ι ↔ N.ι × M.ι`. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean index 14d40bccb9..796af80460 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatBraided -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvGenerator +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` @@ -26,6 +28,8 @@ automatically derives the full `Functor.Monoidal` structure including the `OplaxMonoidal` fields. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean index 30741cbc27..2090301540 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # Monoidal structure on the matrix envelope @@ -27,6 +29,8 @@ multiplication turns into iterated sums that factor via `tensor_sum` and identities reduce componentwise to the corresponding identities in `C`. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean index 5e8c0707a3..c24c69e32d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatBraided +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatBraided /-! # Rigidity of the matrix envelope @@ -20,6 +22,8 @@ identity at each index. When `C` is moreover braided, `Mat_ C` is rigid. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatSemisimple.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatSemisimple.lean index 8ece39fa1d..fd4d556aa7 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatSemisimple.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatSemisimple.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomDichotomy +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.AtomDichotomy /-! # The matrix-envelope trace and semisimplicity @@ -16,6 +18,8 @@ trace criterion once nilpotents are known to have vanishing trace, which the atom decomposition supplies. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.Idempotents diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentMatTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentMatTrace.lean index 0b44d7250a..2512c6d9e4 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentMatTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentMatTrace.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatSemisimple +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.MatSemisimple /-! # The nilpotent leg of the matrix-envelope trace @@ -20,6 +22,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentTrace.lean index 9bed1ad22e..21cfaaca25 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/NilpotentTrace.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement -import LeanPool.RegtsSevenster.RS.Classical.SymFun.HookVanishing +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement +public import LeanPool.RegtsSevenster.RS.Classical.SymFun.HookVanishing /-! # The nilpotent-trace theorem @@ -29,6 +31,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/ObjectTower.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ObjectTower.lean index dfdca2b0d6..fd77ea01db 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/ObjectTower.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ObjectTower.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarPermTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPermCast -import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZetaSharp +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 @@ -22,6 +24,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/PermTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/PermTrace.lean index 8183b26824..c6e3d39357 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/PermTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/PermTrace.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowSplit -import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleTrace +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 @@ -21,6 +23,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/RankDimension.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/RankDimension.lean index b56fe07ad8..70a4c66a84 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/RankDimension.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/RankDimension.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.DimensionDefinitions -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower +module + +public import LeanPool.RegtsSevenster.RS.DimensionDefinitions +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower /-! # Connection ranks as skein dimensions @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarPermTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarPermTrace.lean index 02a7fb7b66..f3f9a7ad82 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarPermTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarPermTrace.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.PermTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarTrace +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.PermTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.ScalarTrace /-! # The scalar cycle-trace formula @@ -16,6 +18,8 @@ the Frobenius formula. Fixed points can be recorded separately from the nontrivial cycles. -/ +@[expose] public section + namespace RS open CategoryTheory CategoryTheory.MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarTrace.lean index 5e8ed1533b..d28788d647 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/ScalarTrace.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Trace -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LinearCategory +module + +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.Trace +public import LeanPool.RegtsSevenster.RS.Classical.CatTheory.LinearCategory /-! # The trace as a complex number @@ -19,6 +21,8 @@ trace fields ask for. Cyclicity carries across the identification unchanged. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleAll.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleAll.lean index 01057e583b..1342bc852d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleAll.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleAll.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactorialTrace -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleEnd +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.BlockFactorialTrace +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SemisimpleEnd /-! # Trace nondegeneracy, in Hom-typed form @@ -21,6 +23,8 @@ what `isSemisimpleRing_of_trace` consumes to make every skein endomorphism algebra semisimple. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleEnd.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleEnd.lean index bb1bfd3ee8..f0333747fd 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleEnd.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SemisimpleEnd.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Algebra.TraceCriterion +module + +public import LeanPool.RegtsSevenster.RS.Classical.Algebra.TraceCriterion /-! # The algebraic trace criterion for envelope endomorphisms diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinDimBound.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinDimBound.lean index fd457862e2..d779db60e0 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinDimBound.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinDimBound.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinementSharp -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower -import LeanPool.RegtsSevenster.RS.Classical.SchurTheory.TensorNonvanishing +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 @@ -25,6 +27,8 @@ the sector traces of `SectorIntertwine.lean` and the binomial determinant of `SymFun/LGVStrict.lean`. -/ +@[expose] public section + namespace RS open Finset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTower.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTower.lean index e301b99d55..6bb118f8fc 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTower.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTower.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinLinear -import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor -import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinement +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 @@ -38,6 +40,8 @@ map `σ ↦ [permFragment σ]` is a genuine `MonoidHom` from `Perm (Fin n)` to `End (SkeinObj.mk n)` by `permFragmentCompose`. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTrace.lean index 55fa0222c9..dfd41ef624 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SkeinTrace.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinTower -import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseUnion -import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarFunctional +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 @@ -18,6 +20,8 @@ it: closing a tensor product multiplies the two closures, proved by bilinear induction down to single fragments. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SuperKill.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SuperKill.lean index 3da4ed05a6..b3f603e520 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SuperKill.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SuperKill.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinDimBound -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaTensorPower +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SkeinDimBound +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.OmegaTensorPower /-! # Square death at the super level @@ -17,6 +19,8 @@ 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPerm.lean index ae252131d3..d1da7d18cc 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPerm.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.CatTheory.TensorPow -import LeanPool.RegtsSevenster.RS.Common.PermTopSplit -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SchurPackage +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 @@ -27,6 +29,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPermCast.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPermCast.lean index 9306d9b0ea..758839de82 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPermCast.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/SymPermCast.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm /-! # The action along the standard embeddings @@ -24,6 +26,8 @@ category is used: additivity of `▷` is `MonoidalPreadditive` and its ℂ-homogeneity is `MonoidalLinear`. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowHom.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowHom.lean index f6467a647f..8e457362ac 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowHom.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowHom.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SymPerm /-! # The tensor power of an endomorphism @@ -17,6 +19,8 @@ and applying `g` to each may be done in either order (`permMor_comp_powHom`). -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowSplit.lean index 60d99a2380..d6ecef2c02 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TensorPowSplit.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowHom -import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleNormal +module + +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.TensorPowHom +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.CycleNormal /-! # Splitting a tensor power into two blocks @@ -20,6 +22,8 @@ that let the trace of a permutation-and-endomorphism word be computed block by block. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZeta.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZeta.lean index de422fc01f..2ad08e8c6c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZeta.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZeta.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.NilpotentTrace -import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaRational -import LeanPool.RegtsSevenster.RS.Classical.SymFun.ZetaExp +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 @@ -28,6 +30,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZetaSharp.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZetaSharp.lean index 1a6c595b9f..8bef49510d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZetaSharp.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/TraceZetaSharp.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Envelope.TraceZeta -import LeanPool.RegtsSevenster.RS.Novel.Envelope.HookConfinementSharp +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 @@ -37,6 +39,8 @@ degree bound, and the threshold is stated in the growth constant itself. -/ +@[expose] public section + namespace RS universe u diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/CircleValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CircleValue.lean index a13826a03e..d6dc605c35 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/CircleValue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CircleValue.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid +module + +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid /-! # The circle value @@ -14,6 +16,8 @@ the superdimension `k − 2ℓ`, which is the value Definition 5 gives a free circle. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/CoordIso.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CoordIso.lean index 0c3fcd3ae2..2eb3017285 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/CoordIso.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CoordIso.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate +module + +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate /-! # The standard-model isomorphism @@ -18,6 +20,8 @@ coordinate conventions: every self-dual object of SuperVect *is* a standard orthosymplectic space, form and all. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/Coordinates.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/Coordinates.lean index 4b211f54c9..e5d87b04a9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/Coordinates.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/Coordinates.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Super.OrthonormalBasis -import LeanPool.RegtsSevenster.RS.Classical.Super.SymplecticBasis -import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdDuality +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 @@ -32,6 +34,8 @@ The route: * `exists_coordinates` assembles the graded statement. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/CopairUnique.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CopairUnique.lean index 14b2ffd823..98a0b77733 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/CopairUnique.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/CopairUnique.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate -import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid +module + +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.Nondegenerate +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdRigid /-! # Uniqueness of the copairing @@ -24,6 +26,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/Nondegenerate.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/Nondegenerate.lean index 7225838d1b..fec8fc42f9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/Nondegenerate.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/Nondegenerate.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Extraction.Coordinates +module + +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.Coordinates /-! # Nondegeneracy from the snake identities @@ -30,6 +32,8 @@ coordinate identification follows unconditionally (`exists_coordinates_of_snake`). -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/SnakeTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/SnakeTransport.lean index 707e25b380..1f0b18eb3e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/SnakeTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/SnakeTransport.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Extraction.CoordIso -import LeanPool.RegtsSevenster.RS.Novel.Extraction.CopairUnique +module + +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CoordIso +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.CopairUnique /-! # The complete standard model @@ -24,6 +26,8 @@ via `tensorHom_def'`, and the transported copairing is then pinned by `stdCopair_unique`. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdDuality.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdDuality.lean index 5e323573fe..b0ecf3a02a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdDuality.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdDuality.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.ProdSum -import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdSuper +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 @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean index 11bfe83b11..f3933574b4 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdDuality +module + +public import LeanPool.RegtsSevenster.RS.Novel.Extraction.StdDuality /-! # Self-duality of the standard super space @@ -17,6 +19,8 @@ the contraction identities `L_C = id` distributed over the graded blocks. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdSuper.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdSuper.lean index 2eef208db5..a8fc4890d7 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdSuper.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdSuper.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition /-! # The standard orthosymplectic super vector space @@ -24,6 +26,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalAgreement.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalAgreement.lean index f2dcfb5f5c..e458b5ee5d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalAgreement.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalAgreement.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalIndependence -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalIndependence +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence /-! # All-internal agreement: Eulerian independence outright @@ -34,6 +36,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalIndependence.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalIndependence.lean index 8972c9fb73..438c4cfec1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalIndependence.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalIndependence.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger /-! # Unconditional independence on all-internal subsets @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedInstance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedInstance.lean index 3afb9fe159..b9760cfc86 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedInstance.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedInstance.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedNat +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedNat /-! # The symmetric skein category @@ -14,6 +16,8 @@ label identities, and the `BraidedCategory`/`SymmetricCategory` instances on `SkeinObj f`. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedNat.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedNat.lean index c7839f4e4f..9164f8bf78 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedNat.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BraidedNat.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalInstance /-! # Braiding naturality, fragment level @@ -13,6 +15,8 @@ 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 -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleClose.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleClose.lean index 052e6355dc..40481b4730 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleClose.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleClose.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarPrep -import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight +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 @@ -22,6 +24,8 @@ collapses to the fragment; and the lifted low-block pairs are then exactly the straight matching. -/ +@[expose] public section + namespace RS section BundleClose diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleMapClasses.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleMapClasses.lean index 4d3c25c76b..b0ce5edf6c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleMapClasses.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleMapClasses.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleTensor -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeRelabel +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 @@ -25,6 +27,8 @@ 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` diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleTensor.lean index a0207fd933..32927df09a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleTensor.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment /-! # The strand bundle is a tensor of strand bundles @@ -16,6 +18,8 @@ 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, diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonExistence.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonExistence.lean index 1801501345..810cfca1b6 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonExistence.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonExistence.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChainAgreement +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChainAgreement /-! # Existence of path-canonical orientations @@ -40,6 +42,8 @@ flags lying on non-canonically oriented boundary-to-boundary chains. chain's canonicality status (`pathCanonical_canonOrientation`). -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonTransport.lean index 1798663b9d..2ea7e87015 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonTransport.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionProduct +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionProduct /-! # Canonical data across a relabel and a glue @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonicalFrame.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonicalFrame.lean index a6712d0b8e..c5a4549377 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonicalFrame.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonicalFrame.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathNonSep -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels +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 @@ -26,6 +28,8 @@ over the anti-canonical chains re-canonicalizes any orientation (`exists_recanonicalize`). -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChainAgreement.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChainAgreement.lean index dd8e6a8c56..34ef5d6690 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChainAgreement.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChainAgreement.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon /-! # Chain agreement of path-canonical orientations @@ -45,6 +47,8 @@ whole chain's values are determined by the pinned seed. chain. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordCount.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordCount.lean index 1a3352fba8..fdf6046ac4 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordCount.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordCount.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta /-! # The chord diagram has half as many chords as the subset has boundary flags @@ -19,6 +21,8 @@ This is what makes "the number of chords" a single notion: it is the diagram, and they agree. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordLabels.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordLabels.lean index 788ca03d7d..c68b4a5055 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordLabels.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordLabels.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordSwapParity +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordSwapParity /-! # Boundary chord labels @@ -16,6 +18,8 @@ concrete bridge from `chordCrossingCount` to the abstract chord parity layer. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordParity.lean index c17e288e4d..5f62d431c5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordParity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordParity.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof /-! # The between-legs parity identity @@ -17,6 +19,8 @@ cut — a nested chord contributes both ends, a crossing chord exactly one. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordSwapParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordSwapParity.lean index 74f1b9c47a..2f368b52ce 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordSwapParity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ChordSwapParity.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordParity -import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger +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 @@ -25,6 +27,8 @@ coexisting crossing predicates: the total crossing parity (`third_chord_reparity` per element). -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotate.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotate.lean index fe8893cfc3..8508c7dc0f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotate.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotate.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc /-! # Rotation of closures @@ -25,6 +27,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotateLeft.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotateLeft.lean index 864a563ee3..4342cec74b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotateLeft.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotateLeft.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate /-! # Mirror rotation of closures @@ -18,6 +20,8 @@ where `Wᵀ` transposes the boundary of `W`. This is the left-mirror variant of `pairCloseComposeRotate`. -/ +@[expose] public section + namespace RS /-! ### The inner-pair pullback -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseUnion.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseUnion.lean index 2cab957ddd..5ee3b48983 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseUnion.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseUnion.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseTensor -import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity -import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic -import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleTensor +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 @@ -22,6 +24,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedAgreement.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedAgreement.lean index b8f9bba2de..53e17b5cf3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedAgreement.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedAgreement.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PathCanon -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionExists -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence +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 @@ -22,6 +24,8 @@ Definition 5 value. This is the base case of the converse's factorization induction. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedCutDispatch.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedCutDispatch.lean index fc16f6fc3f..3139663d54 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedCutDispatch.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedCutDispatch.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge -import LeanPool.RegtsSevenster.RS.Novel.Skein.PropThreeOpen +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 @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedIdentify.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedIdentify.lean index 89aadbd77c..5d878aea03 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedIdentify.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedIdentify.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceCut -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionProduct +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 @@ -23,6 +25,8 @@ identify the relabelled fragment's Definition 5 value with the constrained value downstairs, with no independence input. -/ +@[expose] public section + namespace RS namespace EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.lean index a20e71bcb6..13a0de1f3e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourRecursion +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourRecursion /-! # The composition's own sum @@ -17,6 +19,8 @@ constrained partition value as the weighted sum the iteration carries. -/ +@[expose] public section + namespace RS namespace EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourEmbedding.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourEmbedding.lean index 855723c541..01804ef6b7 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourEmbedding.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourEmbedding.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition -import LeanPool.RegtsSevenster.RS.Common.ListSign +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition +public import LeanPool.RegtsSevenster.RS.Common.ListSign /-! # Embeddings of mixed colours @@ -16,6 +18,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean index 47f07cca83..5a2d68e01f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut -import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeSum +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut +public import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeSum /-! # The colouring correspondence at one cut @@ -24,6 +26,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean index 0da97f4ed3..03c8a885d8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourEmbedding -import LeanPool.RegtsSevenster.RS.DimensionDefinitions +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourEmbedding +public import LeanPool.RegtsSevenster.RS.DimensionDefinitions /-! # Padding a mixed model with unused colours @@ -16,6 +18,8 @@ zero vertex factor. Equality of superdimensions then preserves the free-circle factor as well. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourRecursion.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourRecursion.lean index 88996e99f8..18e1dac499 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourRecursion.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourRecursion.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeTerm -import LeanPool.RegtsSevenster.RS.Novel.Skein.CutSubsetSum +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeTerm +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CutSubsetSum /-! # Iterating the glue @@ -19,6 +21,8 @@ stage and at the base, and the dispatch on whether the stage's cut closes. -/ +@[expose] public section + namespace RS namespace EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeAssoc.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeAssoc.lean index b64b3d05c5..ddbfd691e2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeAssoc.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeAssoc.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeNormal +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeNormal /-! # Associativity of composition @@ -21,6 +23,8 @@ association, and the final meet in the middle via two-stage folding and reordering. -/ +@[expose] public section + namespace RS namespace Fragment diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeNormal.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeNormal.lean index 52b47bf407..d59a645900 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeNormal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeNormal.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold /-! # The interface pair list of a composition @@ -16,6 +18,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeRelabel.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeRelabel.lean index 3d5f981881..c9f904bc89 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeRelabel.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeRelabel.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose -import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PermCompose +public import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight /-! # Free-side relabels pass through composition @@ -24,6 +26,8 @@ its two halves `outPermEquiv_symm_low` and absorption run in either direction. -/ +@[expose] public section + namespace RS /-- The inverse outgoing permutation fixes low labels. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/Composition.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/Composition.lean index 55c9b73c28..ca667920a5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/Composition.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/Composition.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.FlagGraph +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FlagGraph /-! # Fragment composition @@ -21,6 +23,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CompositionEquiv.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CompositionEquiv.lean index 844d0f2817..049abf15ea 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CompositionEquiv.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CompositionEquiv.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle /-! # Composition respects fragment equivalence @@ -15,6 +17,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConnectionRank.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConnectionRank.lean index e0aead1148..662fa636b0 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConnectionRank.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConnectionRank.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.RowSpanRank -import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv +module + +public import LeanPool.RegtsSevenster.RS.Common.RowSpanRank +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv /-! # Connection pairings and the edge-rank hypothesis @@ -24,6 +26,8 @@ literature's supremum over finite submatrices (`edgeRankBounded_iff_submatrixRank`). -/ +@[expose] public section + namespace RS /-- Edge-rank boundedness is monotone in the base. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseAssembly.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseAssembly.lean index d19e0ea8fe..991cd5951e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseAssembly.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseAssembly.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.RSTensor -import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedIdentify -import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedTopSum +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 @@ -19,6 +21,8 @@ as the base's summands, summed over its subsets and over the interface colours. -/ +@[expose] public section + namespace RS namespace EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseDischarge.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseDischarge.lean index b46899ef94..789ebbf214 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseDischarge.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseDischarge.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalAgreement +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.AllInternalAgreement /-! # Unconditional consequences of Eulerian independence @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseFamily.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseFamily.lean index 75c3263b83..7fba06bb70 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseFamily.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseFamily.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConversePair +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConversePair /-! # The pair family and the base sum @@ -18,6 +20,8 @@ the super form pairing of the two fragments' tensors — the tensor side of the Gram identity. -/ +@[expose] public section + namespace RS namespace EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseGram.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseGram.lean index 3d69dae27a..be859368ef 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseGram.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseGram.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.RSTensor -import LeanPool.RegtsSevenster.RS.StatementConverse +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RSTensor +public import LeanPool.RegtsSevenster.RS.StatementConverse /-! # The converse from a super-Gram factorization @@ -21,6 +23,8 @@ the converse it gives is `regts_sevenster_converse` in `RS/TheoremConverse.lean`. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseIdentity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseIdentity.lean index 4176628f04..184ec55bdb 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseIdentity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseIdentity.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseFamily -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseGram +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseFamily +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseGram /-! # The super-Gram identity @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseLift.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseLift.lean index 6533d0eb3f..74ea247cce 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseLift.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseLift.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseAssembly -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceAlternate +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 @@ -16,6 +18,8 @@ iterate over the interface, and the identity when the interface is empty. -/ +@[expose] public section + namespace RS namespace EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConversePair.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConversePair.lean index 0b11054c8f..60b244e400 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConversePair.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConversePair.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseTrip +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseTrip /-! # The pair datum at one pair of subsets @@ -19,6 +21,8 @@ composition's base and sums the results; `ConverseTrip.lean` carries the choice up and down the interface. -/ +@[expose] public section + namespace RS namespace EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseTrip.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseTrip.lean index a85611cd27..d34df9d51d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseTrip.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseTrip.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseLift +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseLift /-! # The interface round trip @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CrossingDelta.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CrossingDelta.lean index 78191a46d5..a09a62c651 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CrossingDelta.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CrossingDelta.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels /-! # The per-step crossing-parity decomposition @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean index 6480ba54d7..08b8c358e8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean @@ -4,11 +4,13 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.DirMatching -import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonicalFrame -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordCount -import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperSpace -import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelChords +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 @@ -29,6 +31,8 @@ order. That is the same orientation the mixed partition function's own through-edge product uses. -/ +@[expose] public section + namespace RS open EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CutSubsetSum.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CutSubsetSum.lean index 09a95490ba..60b7c18f40 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CutSubsetSum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CutSubsetSum.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSubsetBij +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSubsetBij /-! # Subset sums split across a single cut @@ -23,6 +25,8 @@ trips of `GlueSubsetBij`: `dropSubset` recovers the glued subset, pairing-closed subset is always a lift. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DirMatching.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DirMatching.lean index d8867ed525..52ae6e7982 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DirMatching.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DirMatching.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.OrbitCard -import LeanPool.RegtsSevenster.RS.Novel.Skein.InvolutionCard +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 @@ -27,6 +29,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjSubsetSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjSubsetSplit.lean index 2ce56d257b..f8d6c3873a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjSubsetSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjSubsetSplit.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue /-! # Subset splitting over disjoint unions @@ -16,6 +18,8 @@ the first layer of the multiplicativity of the corrected constrained value over `disjUnion`. -/ +@[expose] public section + namespace RS variable {α β : Type} {W₁ : Fragment α} {W₂ : Fragment β} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor.lean index c4da248e78..5ad5486911 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.C +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.C /-! # Factorization over a disjoint union diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean index a54f2b429c..bf2b71a8b0 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.SumLexOrder -import LeanPool.RegtsSevenster.RS.Novel.Skein.InvolutionCard -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjSubsetSplit -import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence +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 @@ -27,6 +29,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean index 306e046cda..0a1cdfa324 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.A +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.A /-! # The disjoint union: colour and value splitting @@ -13,6 +15,8 @@ The colouring sum and the through-summand of a union split into the two components. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean index b0b526f382..0014a7369b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.B +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.B /-! # The disjoint union: canonical migration @@ -12,6 +14,8 @@ import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor.B Migrating canonical data between a union and its components. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean index 5be12fdfd4..1d01ffbc2e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean @@ -4,13 +4,15 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.TheoremQuant -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceOrderIso -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor -import LeanPool.RegtsSevenster.RS.StatementConverse -import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughEdgeCut -import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedCutDispatch -import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedAgreement +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 @@ -24,6 +26,8 @@ value (`EdgeSubset.throughValueC_eq_mixedValue`). Independence across boundary pairings is not needed, there being no boundary. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeColouring.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeColouring.lean index 4040e8e324..7db8d349dc 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeColouring.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeColouring.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexSum -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexSum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels /-! # Colourings of the whole subset @@ -23,6 +25,8 @@ theorem about `EdgeOddColouring` rather than a definition in its own right. -/ +@[expose] public section + namespace RS namespace EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.lean index 066613b1d1..58b5a1607e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeColouring +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeColouring /-! # RS21's colouring sum @@ -26,6 +28,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean index 3988e10dc2..6b47d33e30 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourGlue -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceContract +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 @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/Eulerian.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/Eulerian.lean index f0698f7813..e618d7f6e5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/Eulerian.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/Eulerian.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.PermCongr -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank +module + +public import LeanPool.RegtsSevenster.RS.Common.PermCongr +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank /-! # Eulerian edge subsets and circuit data @@ -18,6 +20,8 @@ edge subsets, the Eulerian condition, transition systems and the circuit count all transport along fragment equivalences. -/ +@[expose] public section + namespace RS variable {α : Type} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ExactPairingInstance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ExactPairingInstance.lean index 9f0e4a5dee..8502843370 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ExactPairingInstance.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ExactPairingInstance.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.SnakeClasses +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BraidedInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SnakeClasses /-! # The exact pairing on the strand object @@ -17,6 +19,8 @@ formulation lives at equal numeral arities and collapses to the identity class. -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FibreValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FibreValue.lean index c97a1bc8a0..4a942e4330 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FibreValue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FibreValue.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords -import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerValue +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 @@ -21,6 +23,8 @@ diagrams: `not_throughIndependenceC` exhibits two path-canonical data with different boundary pairings whose signed values differ. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlagGraph.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlagGraph.lean index 00c1992f73..745096bce2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlagGraph.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlagGraph.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Definitions +module + +public import LeanPool.RegtsSevenster.RS.Definitions /-! # The strand, and the two branches of a glue @@ -17,6 +19,8 @@ checks that closing the strand onto itself yields one free circle and no flags. -/ +@[expose] public section + namespace RS namespace Fragment diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignForm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignForm.lean index 8e462a82fb..1434e5025f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignForm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignForm.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignProduct +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignProduct /-! # The closed form of the flip-sign product @@ -16,6 +18,8 @@ occurs evenly contributes exactly `(−1)^length`. That is the sign bookkeeping the paired step of Proposition 3 runs on. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.lean index 01f8c94221..b3ce8a4312 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet /-! # The sign product of a flip sequence @@ -16,6 +18,8 @@ sequence in which every label occurs evenly contributes exactly `(−1)^length`. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.lean index 0e2187da0c..240b7876f1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.CrossingDelta +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CrossingDelta /-! # The four-label parity identities @@ -27,6 +29,8 @@ 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 -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean index 9e204ecb72..cf3774593d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.Composition +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Composition /-! # Isomorphism theory of fragments @@ -18,6 +20,8 @@ congruences for the fragment operations: relabelling, disjoint union, and single-pair gluing. -/ +@[expose] public section + namespace RS namespace Fragment diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GenBoundaryStates.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GenBoundaryStates.lean index 4358ceac05..e274920e5c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GenBoundaryStates.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GenBoundaryStates.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition /-! # Boundary states over general label types @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueAmbient.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueAmbient.lean index c0e3d16324..7eae7ba466 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueAmbient.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueAmbient.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueComm +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueComm /-! # Gluing in an ambient union @@ -16,6 +18,8 @@ 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} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean index f581b62ec5..78818e8f92 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.CutMatching -import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedCutDispatch +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CutMatching +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedCutDispatch /-! # The chord matching across one glue @@ -22,6 +24,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChords.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChords.lean index e300a0a715..86ce084177 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChords.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChords.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords /-! # The gluing action on chord diagrams @@ -17,6 +19,8 @@ composition over which the pairing-resolved gluing decomposition lives. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean index 9fbac6bfcf..2539c7fc2a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueRelTransport +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueRelTransport /-! # Circuit-count delta across a participating glued interface @@ -32,6 +34,8 @@ rewire. linked and none otherwise. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueComm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueComm.lean index 4138963fef..2be2c238f2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueComm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueComm.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv /-! # Commutation of disjoint single-pair glues @@ -21,6 +23,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCrossDelta.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCrossDelta.lean index ce659fd904..959fde4ab9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCrossDelta.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCrossDelta.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChords +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChords /-! # The crossing-parity delta of the diagram gluing @@ -24,6 +26,8 @@ the converse's per-cut splitting carries. cut chords. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueFold.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueFold.lean index 2d6550ff31..b942345fb2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueFold.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueFold.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.PairDisjoint -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueAmbient +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 @@ -17,6 +19,8 @@ pair list, up to fragment equivalence composed with the canonical relabelling. -/ +@[expose] public section + namespace RS namespace Fragment diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueLedger.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueLedger.lean index 3a79c2f641..995795c3ae 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueLedger.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueLedger.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChord +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChord /-! # The glue ledger at a cut the subset misses @@ -24,6 +26,8 @@ the same on both sides, the chord matching is unchanged, and so is the circuit count. -/ +@[expose] public section + namespace RS namespace EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GluePathMatch.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GluePathMatch.lean index c8a7398c7c..9718131ddf 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GluePathMatch.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GluePathMatch.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChords +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueChords /-! # The boundary pairing of a glued system by chain following @@ -30,6 +32,8 @@ terms of the `pathMatch` of `κ`: lifted one. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueRelTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueRelTransport.lean index 59f7e84f7a..ea017646df 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueRelTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueRelTransport.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSubsetBij +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSubsetBij /-! # Transport of transition data across a single-pair glue @@ -28,6 +30,8 @@ of `GlueCircuitDelta.lean` reads), and prove that edge's flags do not participate. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplit.lean index 288681edc0..07baaa0c84 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplit.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue /-! # The gluing-splitting interface @@ -20,6 +22,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof.lean index effb2e2097..b563670a21 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.C +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.C /-! # The single-pair gluing decomposition diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/A.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/A.lean index fd1517213f..d8bf8db547 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/A.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/A.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCircuitDelta +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCircuitDelta /-! # The single-pair gluing infrastructure @@ -26,6 +28,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/C.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/C.lean index 0e45297142..4edeaf75a9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/C.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/C.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.A +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplitProof.A /-! # The closed and open masters @@ -13,6 +15,8 @@ The per-subset ledgers and the open-cut engine, assembled into the master splitting identities. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSubsetBij.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSubsetBij.lean index 7538643c69..8af489c533 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSubsetBij.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSubsetBij.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplit +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplit /-! # Subset correspondence for single-pair gluing @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GramRank.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GramRank.lean index ebc81ccd73..9cbc4f6256 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GramRank.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GramRank.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank /-! # A factored connection pairing has bounded rank @@ -20,6 +22,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomCompose.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomCompose.lean index 323c662031..23c7ea90b0 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomCompose.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomCompose.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdealLeft +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdealLeft /-! # Composition descends to the Hom spaces @@ -15,6 +17,8 @@ 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomSpaces.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomSpaces.lean index 0b61afb5b3..9c71b745bb 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomSpaces.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomSpaces.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank /-! # Hom spaces of the skein category @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTensor.lean index 2d661281ea..8a0dd047e8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTensor.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorComm +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorComm /-! # The monoidal product descends to the Hom spaces @@ -15,6 +17,8 @@ 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceCyclic.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceCyclic.lean index 58b273aadf..db399aeaf8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceCyclic.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceCyclic.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate /-! # Trace cyclicity on Hom classes @@ -15,6 +17,8 @@ order. Bilinear induction with `fragTrace_comm` at the singles. -/ +@[expose] public section + namespace RS variable {R : ℕ} (f : EdgeRankParameter R) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceNondegenerate.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceNondegenerate.lean index 0cdcc1a181..4e01a22e02 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceNondegenerate.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/HomTraceNondegenerate.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCategory -import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceNondegenerate +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCategory +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceNondegenerate /-! # Trace nondegeneracy on Hom classes @@ -16,6 +18,8 @@ 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean index d81efd3bba..e09575fb2c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv /-! # The identity law: stage equivalences @@ -24,6 +26,8 @@ interface labels `C`, and the outer labels `D`; the shuffle constructor permutation with definitional inverses. -/ +@[expose] public section + namespace RS /-- The five-block shuffle underlying the stage equivalence. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLawRight.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLawRight.lean index 0ed07b45d1..1d680714e1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLawRight.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLawRight.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw /-! # The right identity law: stage equivalences @@ -35,6 +37,8 @@ The stage equivalence maps `Fin (s + u) ⊕ Fin (t' + t')` to 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceAlternate.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceAlternate.lean index 8b8a33b8e1..17b01a8240 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceAlternate.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceAlternate.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedTopSum +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ClosedTopSum /-! # The interface alternates @@ -22,6 +24,8 @@ sides — the unglued orientation's chain directions at the two glued labels are opposite. -/ +@[expose] public section + namespace RS namespace EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceContract.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceContract.lean index ea838423d5..3fb7a3d154 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceContract.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceContract.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerRecursion +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerRecursion /-! # Contracting the interface @@ -24,6 +26,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceCut.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceCut.lean index d5d4a5a5f3..1628634fd2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceCut.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceCut.lean @@ -4,11 +4,13 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueLedger -import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexSum -import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperGram -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceOrderIso -import LeanPool.RegtsSevenster.RS.Novel.Skein.DisjUnionFactor +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 @@ -27,6 +29,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceOrderIso.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceOrderIso.lean index de1f2f4fd7..81d0075e30 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceOrderIso.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceOrderIso.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.SumLexOrder +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SumLexOrder /-! # Monotonicity of the interface re-indexing equivalences @@ -33,6 +35,8 @@ sum orders explicitly through the reducible aliases which are definitionally the projections of `sumLexLinearOrder`. -/ +@[expose] public section + namespace RS /-! ### Pinned instances for the lexicographic sum order -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceShift.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceShift.lean index db4431b1ca..87357425a1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceShift.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceShift.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc /-! # The interface shift @@ -18,6 +20,8 @@ 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` diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InvolutionCard.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InvolutionCard.lean index 418788c0c9..f4b75b2a2a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/InvolutionCard.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InvolutionCard.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.MathlibDeps +module + +public import LeanPool.RegtsSevenster.RS.Common.MathlibDeps /-! # A fixed-point-free involution halves a finset @@ -17,6 +19,8 @@ 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.** -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LabelChords.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LabelChords.lean index 4149023799..58badba453 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LabelChords.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LabelChords.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.PairDisjoint -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels +module + +public import LeanPool.RegtsSevenster.RS.Common.PairDisjoint +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChordLabels /-! # The label chord diagram of a transition system @@ -16,6 +18,8 @@ index over which the pairing-resolved open-sector values live. `SamePairing` is exactly equality of chord diagrams. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerCast.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerCast.lean index bb8b151d83..907feea55e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerCast.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerCast.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerStage +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerStage /-! # Transporting a subset's data along an equality @@ -20,6 +22,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean index d772c59b0b..028385cb15 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerCast -import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientExistence +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerCast +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientExistence /-! # The data the interface recursion carries @@ -21,6 +23,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean index 3e7a188149..0fedeffe66 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet -import LeanPool.RegtsSevenster.RS.Novel.Skein.StatusSet +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StateFlipSet +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StatusSet /-! # Relabel sets for the canonical ledgers @@ -25,6 +27,8 @@ and vanishes on a pairing-preserving one (`statusDiff_of_samePairing`). -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerStage.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerStage.lean index 748a0c9179..be632e510a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerStage.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerStage.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceCut +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceCut /-! # One stage of the interface recursion, with the matchings supplied @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerValue.lean index c7b79ec3c4..f383ee4605 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerValue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerValue.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingValue -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger /-! # The ledgers in value form @@ -19,6 +21,8 @@ existence. The single-step disjunct is a theorem the paired step in value form. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopExample.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopExample.lean index ee4229d148..569eded70b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopExample.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopExample.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge /-! # The loop graph, evaluated @@ -27,6 +29,8 @@ 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 -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopVerify.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopVerify.lean index 713c1eff09..4559e23649 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopVerify.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LoopVerify.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger /-! # A repaired system carrying a path-canonical orientation @@ -30,6 +32,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/MixedPartition.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/MixedPartition.lean index 02bc7b601b..ef7c9ee9ce 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/MixedPartition.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/MixedPartition.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.ListSign -import LeanPool.RegtsSevenster.RS.Novel.Skein.Eulerian +module + +public import LeanPool.RegtsSevenster.RS.Common.ListSign +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Eulerian /-! # Mixed partition functions: the vertex functional @@ -18,6 +20,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalInstance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalInstance.lean index 12a42c0edb..3396549842 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalInstance.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalInstance.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalNat -import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalStruct +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalNat +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MonoidalStruct /-! # The monoidal skein category @@ -16,6 +18,8 @@ and the coherence diagrams, all collapsing through the bundle-map calculus. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalNat.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalNat.lean index 6f07084a41..f70dcfeda8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalNat.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalNat.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleMapClasses -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorAssoc -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorUnit -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorCompClass +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 @@ -19,6 +21,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalStruct.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalStruct.lean index 6b03b9d9b0..da12455d59 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalStruct.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/MonoidalStruct.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleMapClasses -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor +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 @@ -18,6 +20,8 @@ the coherence lemmas provable without the interchange law bundle-map calculus. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/Multiplicativity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/Multiplicativity.lean index c5d6462827..77c0934d8e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/Multiplicativity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/Multiplicativity.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv /-! # Multiplicativity from the rank bound at arity zero @@ -16,6 +18,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/NonSeparatedStep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/NonSeparatedStep.lean index f8fd3bd74b..e7ba9c6515 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/NonSeparatedStep.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/NonSeparatedStep.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger /-! # The non-separated repair move: the flipped-segment ledger @@ -55,6 +57,8 @@ the parity files: merges the circuit into `a`'s component, Δ = −1). -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/OpenCircuits.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/OpenCircuits.lean index cd38471b9c..8e71206886 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/OpenCircuits.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OpenCircuits.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PathMatch +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathMatch /-! # Open circuit count for boundary-relative transition systems @@ -35,6 +37,8 @@ whose forward walk eventually returns to them. not periodic. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrbitParities.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrbitParities.lean index 4130e0614c..c5fb38a206 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrbitParities.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrbitParities.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.NonSeparatedStep -import LeanPool.RegtsSevenster.RS.Novel.Skein.SeparatedParity +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.NonSeparatedStep +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SeparatedParity /-! # The non-separated count parities @@ -48,6 +50,8 @@ The localization needed for `fullPerm_repair` comes from assumption is discharged by well-ordering the label type. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientExistence.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientExistence.lean index 7e4b60b9b1..381e2b6f22 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientExistence.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientExistence.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonTransport +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonTransport /-! # Orientation existence @@ -15,6 +17,8 @@ orbits by the orbit representative gives the directions. Canonical data therefore exist exactly when a transition system does. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean index 7c8cacc63b..951c0fb4fc 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexOddSign +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.VertexOddSign /-! # Orientation invariance of the constrained summand: circuit flips @@ -52,6 +54,8 @@ circuit-supported differences (or fix path orientations by convention). -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairCloseComm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairCloseComm.lean index 90f99bf215..a10f8082fd 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairCloseComm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairCloseComm.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc /-! # Commutativity of pair closure @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean index 676a7ffdf5..48b51d7671 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatusNonsep -import LeanPool.RegtsSevenster.RS.Novel.Skein.FourLabelParity -import LeanPool.RegtsSevenster.RS.Novel.Skein.FlipSignForm +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` @@ -39,6 +41,8 @@ Main results: `chainStatusLedger` (the enriched chain induction), `pairedLedgerUnsigned`, and `pairedLedger`. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingConnectivity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingConnectivity.lean index 2a8e9f2c42..b8b0180970 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingConnectivity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingConnectivity.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger /-! # Pairing-preserving connectivity @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSignature.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSignature.lean index d948603af5..cbcd92df46 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSignature.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSignature.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity /-! # The chord data is a function of the pairing @@ -16,6 +18,8 @@ repairs the crossing count returns — the parity backbone of the holonomy bookkeeping. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSwap.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSwap.lean index 468caeaf70..7213cba815 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSwap.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSwap.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepLedger /-! # The pairing transposition of a non-localized repair @@ -19,6 +21,8 @@ holonomy programme — repair words act on boundary pairings through transposition conjugations. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingValue.lean index a27c3c6575..4ba4ef0376 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingValue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingValue.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSignature /-! # The pairing-resolved signed value @@ -17,6 +19,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialClose.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialClose.lean index eb05f8cebe..ba1f2a2c12 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialClose.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialClose.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeNormal +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeNormal /-! # Partial closure: gluing a fragment into a test fragment @@ -21,6 +23,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseCompose.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseCompose.lean index a0ccd77f7d..8f779fb6a8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseCompose.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseCompose.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseTensor +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialCloseTensor /-! # Partial closure as a composition @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean index 5ce40187e9..bdee3dea67 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal /-! # Partial closure of a tensor @@ -25,6 +27,8 @@ This file: the three-summand shuffle, the ground computation inner-pair identification. -/ +@[expose] public section + namespace RS /-- The three-summand shuffle: pull the middle summand out diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathCanon.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathCanon.lean index bbf8cb3d73..a3c9c4c91e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathCanon.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathCanon.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientationFlip -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCircuitDelta +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientationFlip +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCircuitDelta /-! # Path-canonical orientations and the corrected independence @@ -21,6 +23,8 @@ summand well-defined; the corrected value chooses among canonical data, and the corrected independence interface quantifies over it. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean index 20a3e2dcb9..b758382424 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.RepairInvariance -import LeanPool.RegtsSevenster.RS.Novel.Skein.ChainAgreement +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RepairInvariance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ChainAgreement /-! # The path ledger for the repair move @@ -50,6 +52,8 @@ factor and the case analysis that controls it. `SeparatedParity.lean` and `NonSeparatedStep.lean` respectively. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathMatch.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathMatch.lean index 4c6c5d0686..3b598a2ad2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathMatch.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathMatch.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition /-! # Path matching on boundary flags @@ -31,6 +33,8 @@ chain result and `σ` is the edge pairing), established by induction on `j` using `match_invol`. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PermCompose.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PermCompose.lean index ae45529e46..bde4c847f9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PermCompose.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PermCompose.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PermFragment -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceShift -import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw +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 @@ -23,6 +25,8 @@ permutation is traded for a strand re-indexing of the bundle equivalence. -/ +@[expose] public section + namespace RS /-- A permutation fragment is the strand bundle with its outgoing diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PermFragment.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PermFragment.lean index 7c9ce9c3b3..6f07e7ffe9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PermFragment.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PermFragment.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle /-! # Permutation fragments @@ -16,6 +18,8 @@ of `t` disjoint strands, strand `k` joining incoming boundary label gives the strand bundle. -/ +@[expose] public section + namespace RS /-- The permutation fragment of `σ`: strand `k` joins incoming diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PropThreeOpen.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PropThreeOpen.lean index 68c02275a9..d92b864f51 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PropThreeOpen.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PropThreeOpen.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairedAssembly -import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelChords +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PairedAssembly +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelChords /-! # Proposition 3 for open fragments @@ -20,6 +22,8 @@ constrained value is a function of the boundary pairing, and of nothing else. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean index 2f0dc18369..672fa28c84 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean @@ -4,11 +4,13 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.EdgeSum -import LeanPool.RegtsSevenster.RS.Novel.Skein.CutMatching -import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperGram -import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge +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 @@ -32,6 +34,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelTransition.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelTransition.lean index ee3dc3edc8..f452d675e9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelTransition.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelTransition.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition /-! # Boundary-relative transition systems @@ -47,6 +49,8 @@ degenerates to `TransitionSystem` and `internalCircuitCount` equals `circuitCount`. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelValue.lean index a26281a452..2f476073a7 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelValue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelValue.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition -import LeanPool.RegtsSevenster.RS.Novel.Skein.GenBoundaryStates +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GenBoundaryStates /-! # The boundary-relative constrained summand @@ -19,6 +21,8 @@ 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 α} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelChords.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelChords.lean index cec80e4e23..ca49089180 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelChords.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelChords.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelInvariance -import LeanPool.RegtsSevenster.RS.Novel.Skein.FibreValue +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelabelInvariance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FibreValue /-! # Chord diagrams transport along monotone relabels @@ -16,6 +18,8 @@ and the path matching are untouched, the labels shift through `e`, and `e` preserves the sorting. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelInvariance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelInvariance.lean index db89654a03..94ae11aad1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelInvariance.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelInvariance.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence /-! # Monotone relabel invariance of the corrected constrained value @@ -25,6 +27,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RepairInvariance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RepairInvariance.lean index c315e69ffb..22715b8790 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RepairInvariance.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RepairInvariance.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransitionMove -import LeanPool.RegtsSevenster.RS.Novel.Skein.OrientationFlip +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 @@ -49,6 +51,8 @@ ledger of `PathLedger.lean`, whose statements weigh the summand by the boundary pairing's chord sign. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidInstance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidInstance.lean index 16937da214..6d65a2b156 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidInstance.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidInstance.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ExactPairingInstance /-! # Rigidity of the skein category @@ -17,6 +19,8 @@ definitional, and the flip `1 + n = n + 1` is transported along `eqToIso`). -/ +@[expose] public section + namespace RS open CategoryTheory MonoidalCategory diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidityClasses.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidityClasses.lean index 1d2230b75b..7c6e055be7 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidityClasses.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RigidityClasses.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeRelabel +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeRelabel /-! # The rigidity classes of the skein category @@ -19,6 +21,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarClass.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarClass.lean index e57739591f..d250d5e068 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarClass.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarClass.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal /-! # The scalar class @@ -18,6 +20,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarFunctional.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarFunctional.lean index eaa2af9e4a..f8abb2e2c8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarFunctional.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ScalarFunctional.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate /-! # The scalar functional @@ -17,6 +19,8 @@ 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SeparatedParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SeparatedParity.lean index e7e55af08b..3e9c7b43ba 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SeparatedParity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SeparatedParity.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger /-! # The separated count parity @@ -48,6 +50,8 @@ moves by exactly `±2`, i.e. the circuit count by `±1`. * `separatedCountParity` — the discharged `SeparatedCountParity`. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SimpleUnit.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SimpleUnit.lean index dec29af885..6ca7e19109 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SimpleUnit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SimpleUnit.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.Multiplicativity +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal /-! # The simple unit @@ -18,6 +20,8 @@ nonzero because its closure row at the empty fragment is `f(∅) = 1`. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCatInstance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCatInstance.lean index 4b4a444ab7..a8c745cce9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCatInstance.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCatInstance.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTraceNondegenerate /-! # The skein category, packaged @@ -16,6 +18,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCategory.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCategory.lean index 93d800c62b..475f864c8a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCategory.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinCategory.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomCompose -import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic -import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLawRight +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 @@ -20,6 +22,8 @@ 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdeal.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdeal.lean index 66e23a5286..417e0d5b05 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdeal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdeal.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomSpaces +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomSpaces /-! # The composition ideal @@ -19,6 +21,8 @@ row of the original — the rotation of closures moves the composed factor into the test fragment. -/ +@[expose] public section + noncomputable section namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdealLeft.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdealLeft.lean index 609e7c049a..86312c4a17 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdealLeft.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinIdealLeft.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotateLeft -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotateLeft +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal /-! # The composition ideal, left half @@ -19,6 +21,8 @@ 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, diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinLinear.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinLinear.lean index 47316d1a5e..cb991823e9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinLinear.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SkeinLinear.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance /-! # The skein category is ℂ-linear @@ -14,6 +16,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SnakeClasses.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SnakeClasses.lean index 997e6adba7..12fa182769 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SnakeClasses.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SnakeClasses.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidityClasses -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RigidityClasses +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor /-! # The snake identities on Hom classes @@ -18,6 +20,8 @@ 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)`. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarCompClass.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarCompClass.lean index 143212a22d..e6d9448007 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarCompClass.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarCompClass.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarTrace -import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarFunctional -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCatInstance -import LeanPool.RegtsSevenster.RS.Novel.Skein.ScalarClass +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 @@ -18,6 +20,8 @@ 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarDecomposition.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarDecomposition.lean index 746af7f884..275f2f5c9a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarDecomposition.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarDecomposition.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarExplode -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarExplode +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc /-! # The star decomposition @@ -19,6 +21,8 @@ canonical ones gives `starDecomposition`, the accompanying paper's union glued along the edge matching. -/ +@[expose] public section + namespace RS section Decomposition diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarEnum.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarEnum.lean index 07479c4e23..0af322fabd 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarEnum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarEnum.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarDecomposition +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarDecomposition /-! # The star union with a `Fin`-boundary @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarExplode.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarExplode.lean index 54e4ac6c78..1252abb924 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarExplode.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarExplode.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueFold +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConnectionRank /-! # Exploding a closed fragment into stars @@ -22,6 +24,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarPrep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarPrep.lean index 071dfe4d10..7a158c7c8a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarPrep.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarPrep.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.StarEnum -import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StarEnum +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic /-! # Preparations for the bundle closure @@ -18,6 +20,8 @@ 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 -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarTrace.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarTrace.lean index 0420eede1a..3d1c2168c9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarTrace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarTrace.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleClose +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.BundleClose /-! # The star trace identity @@ -17,6 +19,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StateFlipSet.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StateFlipSet.lean index 8839db04fb..790443ace4 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StateFlipSet.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StateFlipSet.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathNonSep +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathNonSep /-! # Set-indexed state relabels @@ -15,6 +17,8 @@ Composition is symmetric difference, so pairing-returning accumulations cancel by parity. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StatusSet.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StatusSet.lean index cb5cd5bd26..92edcea977 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StatusSet.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StatusSet.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepFrame -import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepFrame +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LabelChords /-! # The high-status set of a pairing @@ -18,6 +20,8 @@ high-status difference of the endpoint pairings — empty exactly when the pairing returns. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepFrame.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepFrame.lean index 0520113041..26edb452ba 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepFrame.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepFrame.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonicalFrame -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingSwap +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 @@ -19,6 +21,8 @@ directions, a constraint on the old frame derived from the new system. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepLedger.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepLedger.lean index 3381e18d5c..5de9e8cd2c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepLedger.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepLedger.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity -import LeanPool.RegtsSevenster.RS.Novel.Skein.OrbitParities -import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathStep +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 @@ -63,6 +65,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatus.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatus.lean index 4071b4d79d..0001193be0 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatus.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatus.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerSets +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LedgerSets /-! # Per-step status identification of the relabel sets @@ -25,6 +27,8 @@ low-in-old (the re-paired ends carry opposite old statuses, on a re-paired end (`mem_highSet_repair_untouched`). -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatusNonsep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatusNonsep.lean index b3dd7e4975..c627a5fa28 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatusNonsep.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StepStatusNonsep.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatus +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StepStatus /-! # The non-separated per-step status identification @@ -37,6 +39,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StrandBundle.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StrandBundle.lean index 222bdb8b63..52e07ddbb0 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StrandBundle.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StrandBundle.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.FragmentEquiv /-! # Strand bundles @@ -16,6 +18,8 @@ boundary label `k` to boundary label `t + k`. Flags are pairs `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` diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SumLexOrder.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SumLexOrder.lean index 4f4ce5030d..5650bbb06e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SumLexOrder.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SumLexOrder.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplit +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplit /-! # The lexicographic order on disjoint-union labels @@ -18,6 +20,8 @@ multiplicativity of the corrected value, first target of the factorization chain. -/ +@[expose] public section + namespace RS -- Deliberately semireducible: supplied explicitly via `letI` in diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperGram.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperGram.lean index fa6b9fb167..7dfd4496ff 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperGram.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperGram.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GramRank -import LeanPool.RegtsSevenster.RS.Novel.Skein.SuperSpace +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 @@ -23,6 +25,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperSpace.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperSpace.lean index 21d8c23eb2..1cae1c03b8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperSpace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SuperSpace.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue /-! # The super-symmetric form on one leg @@ -27,6 +29,8 @@ the tower's colour kernel, which pairs the odd colours through `-oddThroughFactor`. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorAssoc.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorAssoc.lean index 9065003f6e..cb7e04e0cd 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorAssoc.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorAssoc.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment -import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ComposeAssoc /-! # Associativity of the fragment tensor @@ -18,6 +20,8 @@ interleave value lemmas; the associator equivalence follows by pure relabel algebra. -/ +@[expose] public section + namespace RS variable (s₁ t₁ s₂ t₂ s₃ t₃ : ℕ) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorComm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorComm.lean index 3ab53398ad..652ee66ff1 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorComm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorComm.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal -import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorIdeal +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic /-! # Tensor commutativity and the right-slot ideal @@ -16,6 +18,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorCompClass.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorCompClass.lean index 750d4bbb21..98e8c4ca7e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorCompClass.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorCompClass.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorInterchange -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomTensor -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinCategory +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 @@ -16,6 +18,8 @@ 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorFragment.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorFragment.lean index 2e595a9e1f..2c4203eb16 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorFragment.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorFragment.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CompositionEquiv /-! # The tensor product of fragments @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorIdeal.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorIdeal.lean index 2b7d94975b..8231b1cb27 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorIdeal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorIdeal.lean @@ -4,9 +4,11 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment -import LeanPool.RegtsSevenster.RS.Novel.Skein.PartialClose -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal +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 @@ -23,6 +25,8 @@ 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 -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean index ecb56817dc..2bf1659422 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment -import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate /-! # Interchange law of the skein category @@ -20,6 +22,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorUnit.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorUnit.lean index a642808599..b902192e47 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorUnit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorUnit.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TensorFragment /-! # Units of the fragment tensor @@ -14,6 +16,8 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughEdgeCut.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughEdgeCut.lean index 32b46520e9..f64ad763bf 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughEdgeCut.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughEdgeCut.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.GluePathMatch -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueCrossDelta -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseDischarge -import LeanPool.RegtsSevenster.RS.Novel.Skein.PropThreeOpen +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 @@ -19,6 +21,8 @@ transports here are what the colouring recursion needs at such a cut. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughIndCFalse.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughIndCFalse.lean index 4c3176cac8..c9ca98a077 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughIndCFalse.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughIndCFalse.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopVerify +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.LoopVerify /-! # The corrected independence interface is refutable across pairings @@ -22,6 +24,8 @@ interfaces consuming `ThroughIndependenceC` must be re-based on the pairing-resolved value. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughValue.lean index 44dc9a3f94..ab8f9cecfe 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughValue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ThroughValue.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.RelValue -import LeanPool.RegtsSevenster.RS.Novel.Skein.OpenCircuits +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelValue +public import LeanPool.RegtsSevenster.RS.Novel.Skein.OpenCircuits /-! # Through-edges and the corrected constrained value @@ -25,6 +27,8 @@ 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 α} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/Trace.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/Trace.lean index 1fc61e64f6..891afb26d8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/Trace.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/Trace.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle -import LeanPool.RegtsSevenster.RS.Novel.Skein.HomSpaces +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.StrandBundle +public import LeanPool.RegtsSevenster.RS.Novel.Skein.HomSpaces /-! # The categorical trace on Hom spaces @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceCyclic.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceCyclic.lean index 458a4848df..76350122af 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceCyclic.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceCyclic.lean @@ -4,11 +4,13 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.CloseRotate -import LeanPool.RegtsSevenster.RS.Novel.Skein.InterfaceShift -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairCloseComm -import LeanPool.RegtsSevenster.RS.Novel.Skein.IdentityLaw -import LeanPool.RegtsSevenster.RS.Novel.Skein.Trace +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 @@ -25,6 +27,8 @@ commutativity of the closure and the closure-relabel exchange `s = 0`, where the outgoing block is the entire boundary. -/ +@[expose] public section + namespace RS /-- The inverse of the transpose is the reverse transpose. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceNondegenerate.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceNondegenerate.lean index 40c5b92f9d..76ba8f7d3d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceNondegenerate.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TraceNondegenerate.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic -import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TraceCyclic +public import LeanPool.RegtsSevenster.RS.Novel.Skein.SkeinIdeal /-! # Zero negligibles: nondegeneracy of the trace pairing @@ -18,6 +20,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean index 4ec69b0dce..8b799adf7a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.MixedPartition /-! # Existence of transition systems with orientations @@ -26,6 +28,8 @@ orientation. The construction proceeds in two parts: orbit representatives under the flag order. -/ +@[expose] public section + namespace RS /-! ### The involution lemma -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionMove.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionMove.lean index dbf7e0437e..de7263ac94 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionMove.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionMove.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.RelTransition /-! # The elementary re-pairing move on relative transition systems @@ -60,6 +62,8 @@ needs the orbit machinery; that construction is segment. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransposeLedger.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransposeLedger.lean index 6691fabde9..d25f12e973 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransposeLedger.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransposeLedger.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TwoPathStep -import LeanPool.RegtsSevenster.RS.Novel.Skein.PairingConnectivity +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 @@ -53,6 +55,8 @@ separated configuration. The decomposition behind the constant: `ThroughIndCFalse.lean` compares against. -/ +@[expose] public section + namespace RS namespace EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathNonSep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathNonSep.lean index 203abe6baa..53dc13ac62 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathNonSep.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathNonSep.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger -import LeanPool.RegtsSevenster.RS.Novel.Skein.NonSeparatedStep +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.TransposeLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.NonSeparatedStep /-! # The two-path non-separated transform @@ -26,6 +28,8 @@ factor is minus the product of the two end colours' odd-partner signs. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathStep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathStep.lean index b513014823..baaea89dd9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathStep.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathStep.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger -import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.PathLedger +public import LeanPool.RegtsSevenster.RS.Novel.Skein.CanonExistence /-! # The two-path separated move @@ -30,6 +32,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexOddSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexOddSign.lean index 46ccda967a..134f83d09f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexOddSign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexOddSign.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Common.ListAttach -import LeanPool.RegtsSevenster.RS.Novel.Skein.GlueSplit +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 @@ -21,6 +23,8 @@ Flipping the colours on a set `S` negates the sign at the flags of analysis a product of independent local factors. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexSum.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexSum.lean index 2d3df125f6..591cbea980 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexSum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/VertexSum.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ThroughValue /-! # The vertex sum @@ -22,6 +24,8 @@ product, which the graph model instead carries inside the boundary vectors. -/ +@[expose] public section + namespace RS namespace EdgeSubset diff --git a/LeanPool/RegtsSevenster/RS/QuantSector.lean b/LeanPool/RegtsSevenster/RS/QuantSector.lean index 7edf8d9ed9..542f9a515d 100644 --- a/LeanPool/RegtsSevenster/RS/QuantSector.lean +++ b/LeanPool/RegtsSevenster/RS/QuantSector.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.TheoremForward -import LeanPool.RegtsSevenster.RS.Novel.Envelope.SuperKill +module + +public import LeanPool.RegtsSevenster.RS.TheoremForward +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.SuperKill /-! # Assembly of the quantitative theorem @@ -21,6 +23,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/StatementConverse.lean b/LeanPool/RegtsSevenster/RS/StatementConverse.lean index 17e97886eb..531c781bf4 100644 --- a/LeanPool/RegtsSevenster/RS/StatementConverse.lean +++ b/LeanPool/RegtsSevenster/RS/StatementConverse.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence +module + +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.EulerianIndependence /-! # The converse statement, assembled @@ -20,6 +22,8 @@ proved here: the Definition 5 value of any flagless fragment is `(k − 2ℓ) ^ circles`. -/ +@[expose] public section + namespace RS /-! ## The value on flagless fragments -/ diff --git a/LeanPool/RegtsSevenster/RS/Summit.lean b/LeanPool/RegtsSevenster/RS/Summit.lean index 47704803f7..35830802bd 100644 --- a/LeanPool/RegtsSevenster/RS/Summit.lean +++ b/LeanPool/RegtsSevenster/RS/Summit.lean @@ -4,10 +4,12 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.TheoremConverse -import LeanPool.RegtsSevenster.RS.TheoremTotal -import LeanPool.RegtsSevenster.RS.TheoremPadding -import LeanPool.RegtsSevenster.RS.Classical.Deligne.DeligneAssembly +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 @@ -32,6 +34,8 @@ The axiom checks are pinned in `RS/Assembly/BlueprintDeligne.lean`. -/ +@[expose] public section + namespace RS /-- **The Regts–Sevenster theorem**: every graph parameter with diff --git a/LeanPool/RegtsSevenster/RS/TheoremConverse.lean b/LeanPool/RegtsSevenster/RS/TheoremConverse.lean index c77573ba7e..53ac460cdc 100644 --- a/LeanPool/RegtsSevenster/RS/TheoremConverse.lean +++ b/LeanPool/RegtsSevenster/RS/TheoremConverse.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseIdentity +module + +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ConverseIdentity /-! # The Regts–Sevenster theorem, both directions @@ -16,6 +18,8 @@ edge-rank-bounded parameter. With it the characterization and the quantitative round trip rest on Deligne alone. -/ +@[expose] public section + namespace RS diff --git a/LeanPool/RegtsSevenster/RS/TheoremDimension.lean b/LeanPool/RegtsSevenster/RS/TheoremDimension.lean index b23d9126c7..d9d8cae134 100644 --- a/LeanPool/RegtsSevenster/RS/TheoremDimension.lean +++ b/LeanPool/RegtsSevenster/RS/TheoremDimension.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.TheoremTotal -import LeanPool.RegtsSevenster.RS.TheoremConverse +module + +public import LeanPool.RegtsSevenster.RS.TheoremTotal +public import LeanPool.RegtsSevenster.RS.TheoremConverse /-! # Minimum colour dimension and connection-rank growth @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/TheoremForward.lean b/LeanPool/RegtsSevenster/RS/TheoremForward.lean index 8f6bf859a8..e3e496f8ef 100644 --- a/LeanPool/RegtsSevenster/RS/TheoremForward.lean +++ b/LeanPool/RegtsSevenster/RS/TheoremForward.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexHeart -import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDelignePackage +module + +public import LeanPool.RegtsSevenster.RS.Novel.Coordinates.ReindexHeart +public import LeanPool.RegtsSevenster.RS.Novel.Envelope.EnvDelignePackage /-! # The Regts–Sevenster theorem, forward direction @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/TheoremPadding.lean b/LeanPool/RegtsSevenster/RS/TheoremPadding.lean index d10e59113b..f27dc4f0ef 100644 --- a/LeanPool/RegtsSevenster/RS/TheoremPadding.lean +++ b/LeanPool/RegtsSevenster/RS/TheoremPadding.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.TheoremDimension -import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourPadding +module + +public import LeanPool.RegtsSevenster.RS.TheoremDimension +public import LeanPool.RegtsSevenster.RS.Novel.Skein.ColourPadding /-! # Prescribed parity dimensions @@ -16,6 +18,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/TheoremQuant.lean b/LeanPool/RegtsSevenster/RS/TheoremQuant.lean index 4e1fc82ffa..5ce8aa6978 100644 --- a/LeanPool/RegtsSevenster/RS/TheoremQuant.lean +++ b/LeanPool/RegtsSevenster/RS/TheoremQuant.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.SectorDischarge -import LeanPool.RegtsSevenster.RS.Classical.SymFun.LGVStrict +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 @@ -15,6 +17,8 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/TheoremTotal.lean b/LeanPool/RegtsSevenster/RS/TheoremTotal.lean index ef401e636a..9b13510601 100644 --- a/LeanPool/RegtsSevenster/RS/TheoremTotal.lean +++ b/LeanPool/RegtsSevenster/RS/TheoremTotal.lean @@ -4,8 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS.TheoremForward -import LeanPool.RegtsSevenster.RS.Classical.Interfaces.TotalDimension +module + +public import LeanPool.RegtsSevenster.RS.TheoremForward +public import LeanPool.RegtsSevenster.RS.Classical.Interfaces.TotalDimension /-! # The total-dimension Regts–Sevenster theorem @@ -16,6 +18,8 @@ theorem; the dimension bound comes from the polynomial commutant estimate for the full signed colour action. -/ +@[expose] public section + namespace RS open CategoryTheory diff --git a/LeanPool/RegtsSevenster/Solution.lean b/LeanPool/RegtsSevenster/Solution.lean index de423f1df0..e0352aa0c4 100644 --- a/LeanPool/RegtsSevenster/Solution.lean +++ b/LeanPool/RegtsSevenster/Solution.lean @@ -4,7 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: William Whistler -/ -import LeanPool.RegtsSevenster.RS +module + +public import LeanPool.RegtsSevenster.RS /-! # The certification solution @@ -17,6 +19,8 @@ that the kernel accepts them; see `comparator-config.json` and the CI workflow. -/ +@[expose] public section + namespace Certified open RS From 8b384dc760f8ec8d9701763cc11bee607e4300ee Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Fri, 25 Sep 2026 18:46:38 +0000 Subject: [PATCH 27/46] Repair Regts module visibility and exported interfaces --- .../RS/Classical/SchurTheory/StabCount.lean | 2 +- .../RS/Common/PermTopSplit.lean | 3 +- .../RS/Common/YoungDiagrams.lean | 4 +- LeanPool/RegtsSevenster/RS/Definitions.lean | 9 +-- .../RS/Novel/Coordinates/AdjacentWord.lean | 4 +- .../RS/Novel/Envelope/KaroubiMonoidal.lean | 67 +++++++++---------- .../RS/Novel/Envelope/MatMonoidal.lean | 54 +++++++-------- .../RS/Novel/Skein/FragmentEquiv.lean | 12 ++-- 8 files changed, 77 insertions(+), 78 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/StabCount.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/StabCount.lean index bde32e9bbc..5ee8ab95a6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/StabCount.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/StabCount.lean @@ -32,7 +32,7 @@ private lemma sigmaFiberEquiv_symm_val {α : Type*} {β : Type*} (f : α → β) /-! ### Forward and backward maps -/ /-- Forward: a fixing permutation restricts to each fibre. -/ -private def toFibrePerms (f : Fin n → Fin N) (π : Perm (Fin n)) +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 diff --git a/LeanPool/RegtsSevenster/RS/Common/PermTopSplit.lean b/LeanPool/RegtsSevenster/RS/Common/PermTopSplit.lean index f55ca997c7..774339a822 100644 --- a/LeanPool/RegtsSevenster/RS/Common/PermTopSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Common/PermTopSplit.lean @@ -49,7 +49,8 @@ source slots other than the top one and the target slots other than carries one to the other. -/ def restPerm (σ : Perm (Fin (n + 1))) : Perm (Fin n) := (finSuccAboveEquiv (Fin.last n)).trans - ((Equiv.subtypeEquiv σ (ne_last_iff σ)).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 diff --git a/LeanPool/RegtsSevenster/RS/Common/YoungDiagrams.lean b/LeanPool/RegtsSevenster/RS/Common/YoungDiagrams.lean index 0f64a82333..0203c16dab 100644 --- a/LeanPool/RegtsSevenster/RS/Common/YoungDiagrams.lean +++ b/LeanPool/RegtsSevenster/RS/Common/YoungDiagrams.lean @@ -25,8 +25,8 @@ namespace RS /-- The `s × s` square Young diagram. -/ def squareDiagram (s : ℕ) : YoungDiagram := YoungDiagram.ofRowLens (List.replicate s s) <| by - intro i j _ - simp + 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 diff --git a/LeanPool/RegtsSevenster/RS/Definitions.lean b/LeanPool/RegtsSevenster/RS/Definitions.lean index 4406adca3e..a70fd61918 100644 --- a/LeanPool/RegtsSevenster/RS/Definitions.lean +++ b/LeanPool/RegtsSevenster/RS/Definitions.lean @@ -20,9 +20,7 @@ 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 -public import list with no content), so its meaning is determined by this file - -@[expose] public section +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` @@ -40,6 +38,8 @@ 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 @@ -2158,7 +2158,8 @@ private theorem koszulBraiding_naturality_right (X : SuperVect) braiding: swapping odd ⊗ odd elements picks up a factor of −1. -/ instance instBraidedCategory : BraidedCategory SuperVect where braiding := koszulBraidingIso - braiding_naturality_right := fun X {_ _} f => koszulBraiding_naturality_right X f + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjacentWord.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjacentWord.lean index e5d87819a8..9d4d47ee9f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjacentWord.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/AdjacentWord.lean @@ -90,7 +90,7 @@ private theorem extPerm_adjTrans {n : ℕ} (i : Fin n) : - `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`) -/ -private def swap0WordAux (n : ℕ) : (k : ℕ) → k ≤ n → List (Fin n) +def swap0WordAux (n : ℕ) : (k : ℕ) → k ≤ n → List (Fin n) | 0, _ => [] | k + 1, hk => let w := swap0WordAux n k (by omega) @@ -129,7 +129,7 @@ private theorem swap0WordAux_spec (n : ℕ) : swap_comm] /-- Adjacent-transposition word for `swap 0 p`. -/ -private def swap0Word {n : ℕ} (p : Fin (n + 1)) : List (Fin n) := +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)) : diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiMonoidal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiMonoidal.lean index b7eadf57db..5db0e3fe2c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiMonoidal.lean @@ -158,31 +158,29 @@ private theorem rightUnit_inv_nat [Category.{v} C] [MonoidalCategory C] /-! ### Data: `MonoidalCategoryStruct` on `Karoubi C` -/ --- Raised budget: every field carries its own idempotent --- compatibility proof, and they elaborate together. /-- 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, tensorHom_idem X.idem Y.idem⟩ + ⟨X.X ⊗ Y.X, X.p ⊗ₘ Y.p, by exact tensorHom_idem X.idem Y.idem⟩ whiskerLeft X _ _ f := - ⟨X.p ⊗ₘ f.f, karoubi_tensorHom_comm (⟨X.p, by simp [X.idem]⟩ : X ⟶ 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, karoubi_tensorHom_comm f (⟨Y.p, by simp [Y.idem]⟩ : Y ⟶ Y)⟩ - tensorHom f g := ⟨f.f ⊗ₘ g.f, karoubi_tensorHom_comm f g⟩ + ⟨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, - conj_comm _ _ + 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)⟩ + _ (assoc_nat X Y Z))⟩ inv := ⟨(X.p ⊗ₘ (Y.p ⊗ₘ Z.p)) ≫ (α_ X.X Y.X Z.X).inv, - conj_comm _ _ + 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)⟩ + _ (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 _ _ @@ -195,13 +193,13 @@ instance karoubiMonoidalStruct [Category.{v} C] [MonoidalCategory C] : _ (assoc_nat X Y Z) } leftUnitor X := { hom := ⟨(𝟙 (𝟙_ C) ⊗ₘ X.p) ≫ (λ_ X.X).hom, - conj_comm _ _ + by exact (conj_comm _ _ (tensorHom_idem (by simp) X.idem) X.idem - _ (leftUnit_nat X)⟩ + _ (leftUnit_nat X))⟩ inv := ⟨X.p ≫ (λ_ X.X).inv, - conj_comm _ _ X.idem + by exact (conj_comm _ _ X.idem (tensorHom_idem (by simp) X.idem) - _ (leftUnit_inv_nat X)⟩ + _ (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 _ _ @@ -211,13 +209,13 @@ instance karoubiMonoidalStruct [Category.{v} C] [MonoidalCategory C] : exact conj_iso_inv_hom _ _ X.idem _ (leftUnit_nat X) } rightUnitor X := { hom := ⟨(X.p ⊗ₘ 𝟙 (𝟙_ C)) ≫ (ρ_ X.X).hom, - conj_comm _ _ + by exact (conj_comm _ _ (tensorHom_idem X.idem (by simp)) X.idem - _ (rightUnit_nat X)⟩ + _ (rightUnit_nat X))⟩ inv := ⟨X.p ≫ (ρ_ X.X).inv, - conj_comm _ _ X.idem + by exact (conj_comm _ _ X.idem (tensorHom_idem X.idem (by simp)) - _ (rightUnit_inv_nat X)⟩ + _ (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 _ _ @@ -497,21 +495,20 @@ private theorem karoubi_triangle [Category.{v} C] [MonoidalCategory C] -- Apply the C triangle (reassoc form). rw [tensorHom_triangle_eq_assoc] --- Raised budget: `ofTensorHom` takes eleven axioms at once. /-- Those data satisfy the monoidal axioms, each inherited from the ambient category by conjugation. -/ instance karoubiMonoidal - [Category.{v} C] [MonoidalCategory C] : MonoidalCategory (Karoubi C) := - MonoidalCategory.ofTensorHom - (id_tensorHom_id := karoubi_id_tensorHom_id) - (id_tensorHom := karoubi_id_tensorHom) - (tensorHom_id := karoubi_tensorHom_id) - (tensorHom_comp_tensorHom := karoubi_tensorHom_comp) - (associator_naturality := karoubi_associator_naturality) - (leftUnitor_naturality := karoubi_leftUnitor_naturality) - (rightUnitor_naturality := karoubi_rightUnitor_naturality) - (pentagon := karoubi_pentagon) - (triangle := karoubi_triangle) + [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 -/ @@ -604,20 +601,20 @@ private theorem braid_inv_nat /-- 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. -/ -private noncomputable def karoubiBraidingIso +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, - conj_comm _ _ + by exact (conj_comm _ _ (tensorHom_idem X.idem Y.idem) (tensorHom_idem Y.idem X.idem) - _ (braid_nat X Y)⟩ + _ (braid_nat X Y))⟩ inv := ⟨(Y.p ⊗ₘ X.p) ≫ (β_ X.X Y.X).inv, - conj_comm _ _ + by exact (conj_comm _ _ (tensorHom_idem Y.idem X.idem) (tensorHom_idem X.idem Y.idem) - _ (braid_inv_nat X Y)⟩ + _ (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 _ _ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean index 2090301540..70c43dfe42 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean @@ -48,18 +48,18 @@ variable {C : Type u} /-- Tensor product of objects in `Mat_ C`: index by the product, with componentwise tensor in `C`. -/ -@[reducible] private def matTensorObj [Category.{v} C] [MonoidalCategory 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. -/ -private def matTensorHom [Category.{v} C] [Preadditive C] [MonoidalCategory C] +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] private def matTensorUnit +@[reducible] def matTensorUnit [Category.{v} C] [MonoidalCategory C] : Mat_ C := ⟨PUnit, fun _ => 𝟙_ C⟩ /-! ### Structural isomorphisms @@ -70,7 +70,7 @@ of `C`, and all other entries are zero. -/ open scoped Classical in /-- The associator hom in `Mat_ C`. -/ -private def matAssocHom [Category.{v} C] [Preadditive C] [MonoidalCategory 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')) => @@ -85,7 +85,7 @@ private def matAssocHom [Category.{v} C] [Preadditive C] [MonoidalCategory C] open scoped Classical in /-- The associator inv in `Mat_ C`. -/ -private def matAssocInv [Category.{v} C] [Preadditive C] [MonoidalCategory 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') => @@ -100,7 +100,7 @@ private def matAssocInv [Category.{v} C] [Preadditive C] [MonoidalCategory C] open scoped Classical in /-- The left unitor hom in `Mat_ C`. -/ -private def matLeftUnitorHom +def matLeftUnitorHom [Category.{v} C] [Preadditive C] [MonoidalCategory C] (M : Mat_ C) : matTensorObj matTensorUnit M ⟶ M := @@ -111,7 +111,7 @@ private def matLeftUnitorHom open scoped Classical in /-- The left unitor inv in `Mat_ C`. -/ -private def matLeftUnitorInv +def matLeftUnitorInv [Category.{v} C] [Preadditive C] [MonoidalCategory C] (M : Mat_ C) : M ⟶ matTensorObj matTensorUnit M := @@ -122,7 +122,7 @@ private def matLeftUnitorInv open scoped Classical in /-- The right unitor hom in `Mat_ C`. -/ -private def matRightUnitorHom +def matRightUnitorHom [Category.{v} C] [Preadditive C] [MonoidalCategory C] (M : Mat_ C) : matTensorObj M matTensorUnit ⟶ M := @@ -133,7 +133,7 @@ private def matRightUnitorHom open scoped Classical in /-- The right unitor inv in `Mat_ C`. -/ -private def matRightUnitorInv +def matRightUnitorInv [Category.{v} C] [Preadditive C] [MonoidalCategory C] (M : Mat_ C) : M ⟶ matTensorObj M matTensorUnit := @@ -267,31 +267,31 @@ private theorem matRightUnitor_inv_hom simp [this, zero_comp] /-- The associator isomorphism in `Mat_ C`. -/ -private def matAssociator [Category.{v} C] [Preadditive C] [MonoidalCategory 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 := matAssoc_hom_inv M N K - inv_hom_id := matAssoc_inv_hom 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`. -/ -private def matLeftUnitor [Category.{v} C] [Preadditive C] [MonoidalCategory 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 := matLeftUnitor_hom_inv M - inv_hom_id := matLeftUnitor_inv_hom 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`. -/ -private def matRightUnitor [Category.{v} C] [Preadditive C] [MonoidalCategory 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 := matRightUnitor_hom_inv M - inv_hom_id := matRightUnitor_inv_hom M + hom_inv_id := by exact matRightUnitor_hom_inv M + inv_hom_id := by exact matRightUnitor_inv_hom M /-! ### `MonoidalCategoryStruct` instance -/ @@ -512,17 +512,17 @@ private theorem mat_triangle /-- 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) := - MonoidalCategory.ofTensorHom - (id_tensorHom_id := mat_id_tensorHom_id) + [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 := mat_tensorHom_comp) - (associator_naturality := mat_associator_naturality) - (leftUnitor_naturality := mat_leftUnitor_naturality) - (rightUnitor_naturality := mat_rightUnitor_naturality) - (pentagon := mat_pentagon) - (triangle := mat_triangle) + (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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean index cf3774593d..6738864ce3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean @@ -217,7 +217,7 @@ def gluePairClosedCongr Equiv (W₁.gluePairClosed i j h₁) (W₂.gluePairClosed i j h₂) where flagEquiv := e.survivingFlagEquiv i j vertexEquiv := e.vertexEquiv - attach_comm := fun f => e.survivingFlagEquiv_glueAttach i j f + 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) @@ -312,9 +312,9 @@ def gluePairOpenCongr (W₂.gluePairOpen i j hij hopen₂) where flagEquiv := e.survivingFlagEquiv i j vertexEquiv := e.vertexEquiv - attach_comm := fun f => e.survivingFlagEquiv_glueAttach i j f - pairing_comm := fun f => - e.survivingFlagEquiv_rewire hopen₁ hopen₂ f + 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. -/ @@ -349,7 +349,7 @@ def relabelRefl (W : Fragment α) : Equiv (W.relabel (_root_.Equiv.refl α)) W where flagEquiv := _root_.Equiv.refl _ vertexEquiv := _root_.Equiv.refl _ - attach_comm f := relabel_refl_attach_aux W f + attach_comm f := by exact relabel_refl_attach_aux W f pairing_comm := fun _ => rfl circles_eq := rfl @@ -368,7 +368,7 @@ def relabelTrans (W : Fragment α) (e₁ : α ≃ β) {γ : Type} Equiv ((W.relabel e₁).relabel e₂) (W.relabel (e₁.trans e₂)) where flagEquiv := _root_.Equiv.refl _ vertexEquiv := _root_.Equiv.refl _ - attach_comm f := relabel_trans_attach_aux W e₁ e₂ f + attach_comm f := by exact relabel_trans_attach_aux W e₁ e₂ f pairing_comm := fun _ => rfl circles_eq := rfl From 5df7e5341d34e983bc25dfb1d8eb3d12a3a55333 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Fri, 25 Sep 2026 19:31:46 +0000 Subject: [PATCH 28/46] Repair public interfaces across Regts module boundaries --- .../RS/Classical/Deligne/HomFinite.lean | 2 +- .../RS/Classical/Deligne/SymMul.lean | 5 +- .../RS/Classical/SchurTheory/JTPad.lean | 6 +- .../RS/Novel/Envelope/MatBraided.lean | 21 +- .../RS/Novel/Extraction/StdRigid.lean | 4 +- .../RS/Novel/Skein/ColourEmbedding.lean | 5 +- .../RS/Novel/Skein/GlueCircuitDelta.lean | 7 +- .../RS/Novel/Skein/GlueComm.lean | 212 +++++++++--------- .../RS/Novel/Skein/GlueSplitProof/C.lean | 1 + .../RS/Novel/Skein/IdentityLaw.lean | 25 ++- .../RS/Novel/Skein/IdentityLawRight.lean | 28 +-- .../RS/Novel/Skein/OrientationFlip.lean | 2 +- .../RS/Novel/Skein/TransitionExists.lean | 2 +- 13 files changed, 168 insertions(+), 152 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/HomFinite.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HomFinite.lean index 7307ebcd3d..7434ecbdd1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/HomFinite.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/HomFinite.lean @@ -55,7 +55,7 @@ section ScalarEnd variable {A : Type u} /-- Scaling the identity of the tensor unit, as a ℂ-linear map. -/ -private def unitScalarMap +def unitScalarMap [Category.{v} A] [Preadditive A] [Linear ℂ A] [MonoidalCategory A] : ℂ →ₗ[ℂ] (𝟙_ A ⟶ 𝟙_ A) where toFun c := c • 𝟙 (𝟙_ A) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean index 1670febbfd..52aa83fd4f 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SymMul.lean @@ -668,8 +668,9 @@ noncomputable def modPowMulStage 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)) - (legs_whiskerRight_cond A X n _ - (fun a b hab => modPowMul_rel_fst A X n a b hab)) + (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)] diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean index 7098ca2f54..c5c216d851 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean @@ -120,13 +120,13 @@ noncomputable def restrictHead (μ : YoungDiagram) {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) : ℕ), head_maps_head μ hk σ hfix j⟩ + toFun j := ⟨(σ (Fin.castLE hk j) : ℕ), by exact head_maps_head μ hk σ hfix j⟩ invFun j := ⟨(σ⁻¹ (Fin.castLE hk j) : ℕ), - head_maps_head μ hk σ⁻¹ (fun i hi => by + 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⟩ + exact h1.symm) j)⟩ left_inv j := by ext; simp [Fin.val_castLE] right_inv j := by diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean index 31882f97a6..3b22d0ac66 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean @@ -81,7 +81,8 @@ open scoped Classical in section Braided open scoped Classical in -private def matBraidHom [Category.{v} C] [Preadditive C] [MonoidalCategory C] +/-- 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₂) => @@ -92,7 +93,8 @@ private def matBraidHom [Category.{v} C] [Preadditive C] [MonoidalCategory C] else 0 open scoped Classical in -private def matBraidInv [Category.{v} C] [Preadditive C] [MonoidalCategory C] +/-- 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₂) => @@ -173,14 +175,15 @@ private theorem matBraid_inv_hom · intro b _ hb; simp [show ¬(j₁ = b) from Ne.symm hb] · intro b _ hb; simp [show ¬(j₂ = b) from Ne.symm hb] -private def matBraidIso [Category.{v} C] [Preadditive C] [MonoidalCategory C] +/-- 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 := matBraid_hom_inv M N - inv_hom_id := matBraid_inv_hom M N + hom_inv_id := by exact matBraid_hom_inv M N + inv_hom_id := by exact matBraid_inv_hom M N /-! ### Braiding naturality -/ @@ -434,10 +437,10 @@ 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 := mat_braiding_naturality_right - braiding_naturality_left := mat_braiding_naturality_left - hexagon_forward := mat_hexagon_forward - hexagon_reverse := mat_hexagon_reverse + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean index f3933574b4..0667e6b906 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean @@ -280,7 +280,7 @@ noncomputable instance stdExactPairing (k ℓ : ℕ) : ExactPairing (stdSuperPair k ℓ) (stdSuperPair k ℓ) where coevaluation' := stdCopair k ℓ evaluation' := stdForm k ℓ - coevaluation_evaluation' := std_coev_ev k ℓ - evaluation_coevaluation' := std_ev_coev 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/Skein/ColourEmbedding.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourEmbedding.lean index 01804ef6b7..85f3611391 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourEmbedding.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourEmbedding.lean @@ -47,7 +47,8 @@ def dataEmbedding {k ℓ K L : ℕ} (e : MixedColourEmbedding k ℓ K L) : (Multiset.map_injective e.even.injective (congrArg Prod.fst h)) (Finset.map_injective e.odd.toEmbedding (congrArg Prod.snd h)) -private def oddInclusion {ℓ L : ℕ} (h : ℓ ≤ L) +/-- 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⟩ @@ -67,7 +68,7 @@ def ofLE {k ℓ K L : ℕ} (hk : k ≤ K) (hℓ : ℓ ≤ L) : MixedColourEmbedding k ℓ K L where even := Fin.castLEEmb hk odd := OrderEmbedding.ofStrictMono (oddInclusion hℓ) - (oddInclusion_strictMono hℓ) + (by exact oddInclusion_strictMono hℓ) partner_eq := by intro c change oddInclusion hℓ (oddPartner ℓ c) = diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean index 2539c7fc2a..27733644ef 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean @@ -1073,7 +1073,6 @@ private theorem linked_walkMap_injective (κ' : (Fg).RelTransitionSystem) private theorem linked_walkMap_equivariant (κ' : (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 κ') @@ -1279,7 +1278,8 @@ theorem exists_walkPerm_linked (κ' : (Fg).RelTransitionSystem) (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 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 @@ -1323,7 +1323,8 @@ theorem exists_walkPerm_linked (κ' : (Fg).RelTransitionSystem) 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 hbj k hk1 hcontA htermA hperA hperB + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueComm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueComm.lean index 2be2c238f2..a8737aba45 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueComm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueComm.lean @@ -74,7 +74,7 @@ is all each of them has to compute. `{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`. -/ -private def doubleSurvivingSwap (W : Fragment α) {i j k l : α} +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⟩ ∧ @@ -208,7 +208,7 @@ private theorem closedClosed_second_kl /-- 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. -/ -private def closedClosed_equiv [DecidableEq α] +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) @@ -216,10 +216,10 @@ private def closedClosed_equiv [DecidableEq α] (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⟩ - (closedClosed_second_ij W hik hil hjk hjl hclosed_ij hclosed_kl)).Equiv + (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⟩ - (closedClosed_second_kl W hik hil hjk hjl hclosed_ij hclosed_kl)).relabel + (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 @@ -678,7 +678,7 @@ private theorem openOpen_disjoint_equiv_attach_comm 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. -/ -private def openOpen_disjoint_equiv [DecidableEq α] +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) @@ -691,19 +691,21 @@ private def openOpen_disjoint_equiv [DecidableEq α] ((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)).Equiv + (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)) - (openOpen_second_open_kl W hkl hik hil hjk hjl - hopen_ij hopen_kl hfar_ik hfar_il)).relabel + (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 := openOpen_disjoint_equiv_attach_comm W hij hkl hik hil hjk hjl hopen_ij + 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 := openOpen_disjoint_equiv_pairing_comm W hij hkl hik hil hjk hjl hopen_ij + 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 @@ -746,7 +748,7 @@ private theorem closedOpen_second_closed /-- 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`. -/ -private def closedOpen_equiv [DecidableEq α] +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) @@ -755,11 +757,11 @@ private def closedOpen_equiv [DecidableEq α] ((W.gluePairClosed i j hclosed_ij).gluePairOpen ⟨k, hik.symm, hjk.symm⟩ ⟨l, hil.symm, hjl.symm⟩ (fun h => hkl (congrArg Subtype.val h)) - (closedOpen_second_open W hik hil hjk hjl hclosed_ij hopen_kl)).Equiv + (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⟩ - (closedOpen_second_closed W hkl hik hil hjk hjl hclosed_ij - hopen_kl)).relabel + (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 @@ -878,7 +880,7 @@ private theorem openClosed_second_closed /-- 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`. -/ -private def openClosed_equiv [DecidableEq α] +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) @@ -886,12 +888,12 @@ private def openClosed_equiv [DecidableEq α] (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⟩ - (openClosed_second_closed W hij hik hil hjk hjl hopen_ij - hclosed_kl)).Equiv + (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)) - (openClosed_second_open W hik hil hjk hjl hopen_ij hclosed_kl)).relabel + (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 @@ -1264,7 +1266,7 @@ private theorem oneCross_ik_equiv_attach_comm /-- Configuration (2), variant {ik}: one cross-edge `W.pairing(bFi) = bFk`. Both glues are open in both orders; circles = `W.circles`. -/ -private def oneCross_ik_equiv [DecidableEq α] +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) @@ -1275,19 +1277,21 @@ private def oneCross_ik_equiv [DecidableEq α] ((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)).Equiv + (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)) - (oneCross_ik_second_open_ij W hij hkl hik hil hjk hjl hopen_kl hcross - hfar_jl)).relabel + (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 := oneCross_ik_equiv_attach_comm W hij hkl hik hil hjk hjl hopen_ij hopen_kl + 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 := oneCross_ik_equiv_pairing_comm W hij hkl hik hil hjk hjl hopen_ij + 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 @@ -1340,7 +1344,7 @@ private theorem oneCross_il_second_open_ij /-- Configuration (2), variant {il}: one cross-edge `W.pairing(bFi) = bFl`. Both glues are open in both orders; circles = `W.circles`. -/ -private def oneCross_il_equiv [DecidableEq α] +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) @@ -1351,13 +1355,13 @@ private def oneCross_il_equiv [DecidableEq α] ((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_il_second_open_kl W hij hkl hik hil hjk hjl - hopen_ij hopen_kl hcross hfar_jk)).Equiv + (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)) - (oneCross_il_second_open_ij W hij hkl hik hil hjk hjl - hopen_ij hopen_kl hcross hfar_jk)).relabel + (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 @@ -1577,7 +1581,7 @@ private theorem oneCross_jk_second_open_ij /-- Configuration (2), variant {jk}: one cross-edge `W.pairing(bFj) = bFk`. Both glues are open in both orders; circles = `W.circles`. -/ -private def oneCross_jk_equiv [DecidableEq α] +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) @@ -1588,13 +1592,13 @@ private def oneCross_jk_equiv [DecidableEq α] ((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_jk_second_open_kl W hij hkl hik hil hjk hjl - hopen_ij hcross hfar_il)).Equiv + (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)) - (oneCross_jk_second_open_ij W hij hkl hik hil hjk hjl - hopen_kl hcross hfar_il)).relabel + (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 @@ -2046,7 +2050,7 @@ private theorem oneCross_jl_equiv_attach_comm /-- Configuration (2), variant {jl}: one cross-edge `W.pairing(bFj) = bFl`. Both glues are open in both orders; circles = `W.circles`. -/ -private def oneCross_jl_equiv [DecidableEq α] +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) @@ -2057,19 +2061,21 @@ private def oneCross_jl_equiv [DecidableEq α] ((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)).Equiv + (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)) - (oneCross_jl_second_open_ij W hij hkl hik hil hjk hjl - hopen_ij hopen_kl hcross hfar_ik)).relabel + (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 := oneCross_jl_equiv_attach_comm W hij hkl hik hil hjk hjl hopen_ij hopen_kl + 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 := oneCross_jl_equiv_pairing_comm W hij hkl hik hil hjk hjl hopen_ij + 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 @@ -2114,7 +2120,7 @@ private theorem twoCross_ikjl_second_closed_ij /-- Configuration (3), variant {ik,jl}: two cross-edges. First glue is open, second is closed; circles = `W.circles + 1`. -/ -private def twoCross_ikjl_equiv [DecidableEq α] +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) @@ -2124,12 +2130,12 @@ private def twoCross_ikjl_equiv [DecidableEq α] (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⟩ - (twoCross_ikjl_second_closed_kl W hij hkl hik hil hjk hjl - hopen_ij hcross_ik hcross_jl)).Equiv + (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⟩ - (twoCross_ikjl_second_closed_ij W hij hkl hik hil hjk hjl - hopen_kl hcross_ik hcross_jl)).relabel + (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 @@ -2215,7 +2221,7 @@ private theorem twoCross_iljk_second_closed_ij /-- Configuration (3), variant {il,jk}: two cross-edges. First glue is open, second is closed; circles = `W.circles + 1`. -/ -private def twoCross_iljk_equiv [DecidableEq α] +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) @@ -2225,12 +2231,12 @@ private def twoCross_iljk_equiv [DecidableEq α] (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⟩ - (twoCross_iljk_second_closed_kl W hij hkl hik hil hjk hjl - hopen_ij hcross_il hcross_jk)).Equiv + (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⟩ - (twoCross_iljk_second_closed_ij W hij hkl hik hil hjk hjl - hopen_kl hcross_il hcross_jk)).relabel + (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 @@ -2293,98 +2299,98 @@ def gluePairComm [DecidableEq α] 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 _ (closedClosed_second_ij W hik hil hjk hjl h_ij - h_kl)] - rw [gluePair_eq_closed _ (closedClosed_second_kl W hik hil hjk hjl h_ij - h_kl)] - exact closedClosed_equiv W hij hkl hik hil hjk hjl h_ij 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 _ (closedOpen_second_open W hik hil hjk hjl h_ij - h_kl)] - rw [gluePair_eq_closed _ (closedOpen_second_closed W hkl hik hil hjk hjl - h_ij h_kl)] - exact closedOpen_equiv W hij hkl hik hil hjk hjl h_ij 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 _ (openClosed_second_closed W hij hik hil hjk hjl - h_ij h_kl)] - rw [gluePair_eq_open _ (openClosed_second_open W hik hil hjk hjl h_ij - h_kl)] - exact openClosed_equiv W hij hkl hik hil hjk hjl h_ij 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 _ (twoCross_ikjl_second_closed_kl W hij hkl hik + 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 _ (twoCross_ikjl_second_closed_ij W hij hkl hik + 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 twoCross_ikjl_equiv W hij hkl hik hil hjk hjl h_ij h_kl + 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 _ (oneCross_ik_second_open_kl W hij hkl hik hil + 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 _ (oneCross_ik_second_open_ij W hij hkl hik hil + 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 oneCross_ik_equiv W hij hkl hik hil hjk hjl h_ij h_kl + 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 _ (twoCross_iljk_second_closed_kl W hij hkl + 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 _ (twoCross_iljk_second_closed_ij W hij hkl + 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 twoCross_iljk_equiv W hij hkl hik hil hjk hjl h_ij h_kl + 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 _ (oneCross_il_second_open_kl W hij hkl hik hil + 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 _ (oneCross_il_second_open_ij W hij hkl hik hil + 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 oneCross_il_equiv W hij hkl hik hil hjk hjl h_ij h_kl + 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 _ (oneCross_jk_second_open_kl W hij hkl hik hil + 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 _ (oneCross_jk_second_open_ij W hij hkl hik hil + 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 oneCross_jk_equiv W hij hkl hik hil hjk hjl h_ij h_kl + 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 _ (oneCross_jl_second_open_kl W hij hkl hik + 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 _ (oneCross_jl_second_open_ij W hij hkl hik + 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 oneCross_jl_equiv W hij hkl hik hil hjk hjl h_ij h_kl + 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 _ (openOpen_second_open_ij W hij hik hil hjk + 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 _ (openOpen_second_open_kl W hkl hik hil hjk + 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 openOpen_disjoint_equiv W hij hkl hik hil hjk hjl h_ij h_kl + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/C.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/C.lean index 4edeaf75a9..5a16946af8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/C.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueSplitProof/C.lean @@ -624,6 +624,7 @@ theorem evenPushOpen_covers {k ℓ : ℕ} 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean index e09575fb2c..6e080a7679 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean @@ -464,19 +464,22 @@ theorem interfaceStepEquiv_eval_inr_above (s t u : ℕ) (j : ℕ) /-! ### The stage step equivalence -/ -private abbrev baseFragment (t t' u : ℕ) (ht : t' + 1 ≤ t) +/-- 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) -private abbrev targetFragment (t t' u : ℕ) (ht' : t' ≤ t) +/-- 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') -private noncomputable abbrev sourceFragment (t t' u : ℕ) (ht : t' + 1 ≤ t) +/-- 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) (stageStep_hopen t t' u ht F)).relabel (interfaceStepEquiv t t' u) + (by simp) (by exact stageStep_hopen t t' u ht F)).relabel (interfaceStepEquiv t t' u) -- Raised budget: the four equivalence fields are checked against -- the glued fragment at once, each on both label halves. @@ -996,7 +999,7 @@ private theorem stageStep_pairing (t t' u : ℕ) (ht : t' + 1 ≤ t) /-- 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. -/ -private noncomputable def stageStepEquiv (t t' u : ℕ) (ht : t' + 1 ≤ t) +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 @@ -1008,7 +1011,7 @@ private noncomputable def stageStepEquiv (t t' u : ℕ) (ht : t' + 1 ≤ t) 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 := stageStep_pairing t t' u ht F + 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. -/ @@ -1046,12 +1049,12 @@ def Fragment.Equiv.relabelPointwiseId (W : Fragment α) (e : α ≃ α) /-- In the base fragment, the glue is always open, so `gluePair` coincides with `gluePairOpen`. -/ -private theorem baseFragment_gluePair_eq (t t' u : ℕ) (ht : t' + 1 ≤ t) +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) (stageStep_hopen t t' u ht F) := by + (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) @@ -1059,7 +1062,7 @@ private theorem baseFragment_gluePair_eq (t t' u : ℕ) (ht : t' + 1 ≤ t) down to zero, with the stage-`t'` fragment, yields a result equivalent to iterating from stage `t` on the original strand/F union. -/ -private noncomputable def glueInterface_strandBundle_desc +noncomputable def glueInterfaceStrandBundleDescent (t u : ℕ) (F : Fragment (Fin (t + u))) : ∀ (t' : ℕ) (ht' : t' ≤ t), (glueInterface t t u ((strandBundle t).disjUnion F)).Equiv @@ -1074,7 +1077,7 @@ private noncomputable def glueInterface_strandBundle_desc (stageEquiv_self _ u)).symm) · -- Step: t' < t, use stageStepEquiv to descend one level have ht'_lt : t' + 1 ≤ t := by omega - have ih := glueInterface_strandBundle_desc t u F (t' + 1) ht'_lt + 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'. @@ -1095,7 +1098,7 @@ noncomputable def composeStrandBundleLeft (t u : ℕ) (F : Fragment (Fin (t + u))) : ((strandBundle t).compose F).Equiv F := (Fragment.Equiv.relabelCongr - (glueInterface_strandBundle_desc t u F 0 (Nat.zero_le t)) + (glueInterfaceStrandBundleDescent t u F 0 (Nat.zero_le t)) finSumFinEquiv).trans (stageZeroEquiv t u F) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLawRight.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLawRight.lean index 1d680714e1..d3b1b1bfcc 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLawRight.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLawRight.lean @@ -280,10 +280,7 @@ noncomputable def stageStepFlagEquivR (s t' u : ℕ) (ht : t' + 1 ≤ u) rw [stageStepR_rightBoundary] exact hk_eq ▸ hbfalse ▸ congrArg Sum.inr (Prod.ext (Fin.ext rfl) rfl)) - simp only [dite_eq_right hlt, - show F.boundaryFlag ⟨s + t', by omega⟩ = F.boundaryFlag - ⟨s + t', by omega⟩ from rfl, - dite_true] + 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 @@ -300,19 +297,22 @@ noncomputable def stageStepFlagEquivR (s t' u : ℕ) (ht : t' + 1 ≤ u) /-! ### The stage step equivalence -/ -private abbrev baseFragmentR (s t' u : ℕ) (ht : t' + 1 ≤ u) +/-- 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) -private abbrev targetFragmentR (s t' u : ℕ) (ht' : t' ≤ u) +/-- 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') -private noncomputable abbrev sourceFragmentR (s t' u : ℕ) (ht : t' + 1 ≤ u) +/-- 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) (stageStepR_hopen s t' u ht F)).relabel (interfaceStepEquiv s t' + (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) @@ -808,7 +808,7 @@ private theorem stageStepR_pairing_inr (s t' u : ℕ) (ht : t' + 1 ≤ u) /-- 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. -/ -private noncomputable def stageStepEquivR (s t' u : ℕ) (ht : t' + 1 ≤ u) +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 @@ -838,12 +838,12 @@ theorem stageEquivR_self (s u : ℕ) (x : Fin (s + u) ⊕ Fin (u + u)) : /-- In the base fragment, the glue is always open, so `gluePair` coincides with `gluePairOpen`. -/ -private theorem baseFragmentR_gluePair_eq (s t' u : ℕ) (ht : t' + 1 ≤ u) +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) (stageStepR_hopen s t' u ht F) := by + (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) @@ -851,7 +851,7 @@ private theorem baseFragmentR_gluePair_eq (s t' u : ℕ) (ht : t' + 1 ≤ u) down to zero, with the stage-`t'` fragment, yields a result equivalent to iterating from stage `u` on the original F/strand union. -/ -private noncomputable def glueInterface_strandBundle_desc_right +noncomputable def glueInterfaceStrandBundleDescentRight (s u : ℕ) (F : Fragment (Fin (s + u))) : ∀ (t' : ℕ) (ht' : t' ≤ u), (glueInterface s u u (F.disjUnion (strandBundle u))).Equiv @@ -864,7 +864,7 @@ private noncomputable def glueInterface_strandBundle_desc_right ((Fragment.Equiv.relabelPointwiseId _ _ (stageEquivR_self _ u)).symm) · have ht'_lt : t' + 1 ≤ u := by omega - have ih := glueInterface_strandBundle_desc_right s u F (t' + 1) ht'_lt + 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) = @@ -882,7 +882,7 @@ noncomputable def composeStrandBundleRight (s u : ℕ) (F : Fragment (Fin (s + u))) : (F.compose (strandBundle u)).Equiv F := (Fragment.Equiv.relabelCongr - (glueInterface_strandBundle_desc_right s u F 0 (Nat.zero_le u)) + (glueInterfaceStrandBundleDescentRight s u F 0 (Nat.zero_le u)) finSumFinEquiv).trans (stageZeroEquivR s u F) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean index 951c0fb4fc..330d4a94e6 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientationFlip.lean @@ -874,7 +874,7 @@ open EdgeSubset circles := 0 /-- The full edge subset. -/ -private def exSubset : EdgeSubset exFragment := +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} := diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean index 8b799adf7a..55a8643e69 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean @@ -386,7 +386,7 @@ section Orientation variable {α : Type} {W : Fragment α} {F : EdgeSubset W} /-- In a linear order, a ≠ b implies decide(a < b) = !decide(b < a). -/ -private theorem decide_lt_flip {γ : Type} [LinearOrder γ] +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 From 030b88e1a63604317ed604d06a9565a48d311283 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Fri, 25 Sep 2026 20:13:08 +0000 Subject: [PATCH 29/46] Repair remaining Regts interfaces and tensor-power reassociation --- .../Classical/Deligne/BaseChangeCoherence.lean | 2 +- .../RS/Classical/Deligne/PowPairing.lean | 15 ++++++--------- .../Classical/Deligne/SuperEmbed/Standard.lean | 2 +- .../RS/Novel/Coordinates/CircuitCount.lean | 2 +- .../RS/Novel/Envelope/MatRigid.lean | 4 ++-- .../RS/Novel/Skein/GlueAmbient.lean | 18 +++++++++--------- .../RS/Novel/Skein/PathCanon.lean | 1 + .../RS/Novel/Skein/RepairInvariance.lean | 2 ++ 8 files changed, 23 insertions(+), 23 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean index 7436bfa8bc..22cb374851 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeCoherence.lean @@ -104,6 +104,7 @@ theorem projFormula_cover (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 _ ?_) @@ -654,7 +655,6 @@ theorem projFormula_assoc_core erw [← MonoidalCategory.whiskerLeft_comp, hcov, MonoidalCategory.whiskerLeft_comp, MonoidalCategory.whiskerLeft_comp] - simp only [Category.assoc] rw [reassoc_of% (baseAssoc B M.X N.X P.X)] conv_rhs => rw [MonoidalCategory.whiskerLeft_comp] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean index cfb09e1f85..fc194eb3bc 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowPairing.lean @@ -339,9 +339,9 @@ theorem concat_peel_head [Category.{v} D] [MonoidalCategory D] (X : D) (α_ 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] - all_goals simp only [Category.assoc] - show (α_ (tensorPow D X (p + 1)) (tensorPow D X q) X).inv ≫ + 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) ≫ @@ -577,7 +577,6 @@ theorem rawPair_actRight_last conv_lhs => rw [← whisker_exchange_assoc, associator_naturality_middle_assoc] conv_lhs => simp only [← MonoidalCategory.whiskerLeft_comp_assoc] - conv_lhs => simp only [Category.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 ▷ @@ -631,7 +630,6 @@ theorem pairStep_actRight conv_lhs => rw [pairStep] conv_lhs => rw [associator_naturality_middle_assoc] conv_lhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc] - conv_lhs => simp only [Category.assoc] conv_lhs => rw [inner_extract A M M' d R] conv_rhs => rw [pairStep] conv_rhs => simp only [comp_whiskerRight, @@ -660,7 +658,6 @@ theorem pairStep_actHead conv_lhs => rw [pairStep] conv_lhs => rw [associator_naturality_right_assoc] conv_lhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc] - conv_lhs => simp only [Category.assoc] conv_lhs => rw [inner_extract_snd A M M' d R] conv_rhs => rw [pairStep] conv_rhs => simp only [comp_whiskerRight, @@ -1082,7 +1079,6 @@ theorem pairStep_slide_snd conv_lhs => rw [winLegM, pairStep] conv_lhs => rw [associator_naturality_right_assoc] conv_lhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc] - conv_lhs => simp only [Category.assoc] conv_lhs => rw [hM] conv_rhs => rw [pairStep] conv_rhs => simp only [comp_whiskerRight, @@ -1697,8 +1693,9 @@ noncomputable def pairPowStage 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) - (legs_whiskerRight_cond' A (rawPair A M M' d n) - (fun a b hab => rawPair_rel_fst' A M M' d a b hab)) + (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)] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean index e0e6c1fb85..eae6730e54 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperEmbed/Standard.lean @@ -836,7 +836,7 @@ noncomputable def stdSuperLetters (p q : ℕ) : = 0 exact Pi.single_eq_of_ne (M := fun _ : Fin (q + 1) => ℂ) (fun h => hkk' (congrArg Sum.inr h.symm)) (v 0) - total := stdSuper_total p q + total := by exact stdSuper_total p q /-- **Reconstruction in `SuperVect`**: vanishing colour sums force the block idempotent to kill the standard super object. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircuitCount.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircuitCount.lean index 6382c87860..49be34aef9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircuitCount.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircuitCount.lean @@ -196,7 +196,7 @@ 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 => κ.pairingPerm_isOut_flip o a) + 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) : diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean index c24c69e32d..28c79b0daa 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean @@ -391,8 +391,8 @@ noncomputable def matExactPairing ExactPairing M (matRightDualObj M) where coevaluation' := matCoev M evaluation' := matEv M - coevaluation_evaluation' := mat_snake_one M - evaluation_coevaluation' := mat_snake_two 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueAmbient.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueAmbient.lean index 7eae7ba466..1ca20ab559 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueAmbient.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueAmbient.lean @@ -182,7 +182,7 @@ private theorem gluePairClosed_disjUnion_pairing_comm (W : Fragment α) (V : /-- 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. -/ -private noncomputable def gluePairClosed_disjUnion (W : Fragment α) (V : +noncomputable def gluePairClosedDisjUnion (W : Fragment α) (V : Fragment β) {i j : α} (hclosed : W.pairing (W.boundaryFlag i) = W.boundaryFlag j) : @@ -192,8 +192,8 @@ private noncomputable def gluePairClosed_disjUnion (W : Fragment α) (V : (ambientLabelEquiv i j)) where flagEquiv := ambientFlagEquiv W V i j vertexEquiv := _root_.Equiv.refl (W.Vertex ⊕ V.Vertex) - attach_comm := gluePairClosed_disjUnion_attach_comm W V hclosed - pairing_comm := gluePairClosed_disjUnion_pairing_comm W V hclosed + 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 @@ -327,7 +327,7 @@ private theorem gluePairOpen_disjUnion_pairing_comm (W : Fragment α) (V : Fragm /-- The open case of glue-in-ambient: when the two boundary flags bound distinct edges in W, the LHS and RHS produce equivalent fragments. -/ -private noncomputable def gluePairOpen_disjUnion (W : Fragment α) (V : Fragment +noncomputable def gluePairOpenDisjUnion (W : Fragment α) (V : Fragment β) {i j : α} (hij : i ≠ j) (hopen : W.pairing (W.boundaryFlag i) ≠ W.boundaryFlag j) : @@ -338,8 +338,8 @@ private noncomputable def gluePairOpen_disjUnion (W : Fragment α) (V : Fragment (ambientLabelEquiv i j)) where flagEquiv := ambientFlagEquiv W V i j vertexEquiv := _root_.Equiv.refl (W.Vertex ⊕ V.Vertex) - attach_comm := gluePairOpen_disjUnion_attach_comm W V hij hopen - pairing_comm := gluePairOpen_disjUnion_pairing_comm W V hij hopen + 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 @@ -363,7 +363,7 @@ noncomputable def gluePairDisjUnion (W : Fragment α) (V : Fragment β) (W.disjUnion V).boundaryFlag (Sum.inl j) := congrArg Sum.inl hclosed rw [dite_eq_left hunion] - exact gluePairClosed_disjUnion W V hclosed + 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 @@ -371,7 +371,7 @@ noncomputable def gluePairDisjUnion (W : Fragment α) (V : Fragment β) (W.disjUnion V).boundaryFlag (Sum.inl j) := fun h => hopen (Sum.inl.inj h) rw [dite_eq_right hunion] - exact gluePairOpen_disjUnion W V hij hopen + exact gluePairOpenDisjUnion W V hij hopen /-- The label condition transported along a relabelling. -/ private theorem relabelSurvIff (e : α ≃ β) (i j : β) (x : α) : @@ -420,7 +420,7 @@ noncomputable def gluePairRelabel (W : Fragment α) (e : α ≃ β) ((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 (relabelSurvIff e i j))) + (e.subtypeEquiv (by exact relabelSurvIff e i j))) := by by_cases hclosed : W.pairing (W.boundaryFlag (e.symm i)) = W.boundaryFlag (e.symm j) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathCanon.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathCanon.lean index a3c9c4c91e..d397454244 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathCanon.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathCanon.lean @@ -92,6 +92,7 @@ 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RepairInvariance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RepairInvariance.lean index 22715b8790..9bd14e447e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RepairInvariance.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RepairInvariance.lean @@ -386,6 +386,7 @@ theorem throughSummand_congr [LinearOrder α] {k ℓ : ℕ} (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 @@ -811,6 +812,7 @@ theorem throughSummand_transportRepair (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, From a3482e6237b048eb81be32033529f90547ed2f02 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Fri, 25 Sep 2026 20:36:13 +0000 Subject: [PATCH 30/46] Repair Regts fold and graded module interfaces --- .../RS/Classical/Deligne/ChainBGraded.lean | 4 +-- .../RS/Classical/Deligne/MixDegenerate.lean | 2 +- .../RS/Classical/Deligne/PowCopairing.lean | 1 - .../RS/Classical/Deligne/SuperGammaInst.lean | 10 ++++--- .../RS/Novel/Skein/CanonExistence.lean | 1 + .../RS/Novel/Skein/ClosedAgreement.lean | 1 + .../RS/Novel/Skein/GlueFold.lean | 26 ++++++++++++------- .../RS/Novel/Skein/PathLedger.lean | 6 +++++ 8 files changed, 34 insertions(+), 17 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean index d6aebf67fe..21a15a6729 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGraded.lean @@ -250,7 +250,7 @@ noncomputable def chainBdegZeroIso (fun k => chainDelta2 A M M' d (0 + k) (0 + k)) (chainDelta A M M' d) (chainBdegZeroStageIso A M M') - (chainBdegZeroStage_compatibility A M M' d) + (by exact chainBdegZeroStage_compatibility A M M' d) end ZeroLine @@ -313,7 +313,7 @@ noncomputable def chainBdegSuccIso (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₀) - (chainBdegSuccStage_compatibility A M M' d 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)) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean index 1710e526b5..d922d853f6 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/MixDegenerate.lean @@ -285,7 +285,7 @@ noncomputable def superLetters (r s : ℕ) : 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 := superSum_total r s + total := by exact superSum_total r s end SuperLetters diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowCopairing.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowCopairing.lean index f13b3afe16..fcab6e8832 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowCopairing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PowCopairing.lean @@ -186,7 +186,6 @@ theorem modTensorAct_swap rw [h, Iso.inv_hom_id_assoc] conv_lhs => rw [whiskerLeft_modTensorπ_act_assoc, modTensorπ_swap] - conv_lhs => simp only [Category.assoc] conv_lhs => rw [BraidedCategory.braiding_naturality_left_assoc, hleg] conv_rhs => rw [← MonoidalCategory.whiskerLeft_comp_assoc, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean index 62937c9c6c..439797480c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperGammaInst.lean @@ -414,7 +414,7 @@ private instance : Subsingleton (stdSuper 0 1 ⊗ stdSuper 0 1).odd := /-- A product with a subsingleton first factor is its second factor. -/ -private def prodZeroEquiv (A M : Type) [AddCommGroup A] +def prodZeroEquiv (A M : Type) [AddCommGroup A] [Module ℂ A] [AddCommGroup M] [Module ℂ M] [Subsingleton A] : (A × M) ≃ₗ[ℂ] M where toFun p := p.2 @@ -425,7 +425,7 @@ private def prodZeroEquiv (A M : Type) [AddCommGroup A] right_inv _ := rfl /-- The square of the scalar line, trivialized. -/ -private def lineTensorEquiv : +def lineTensorEquiv : (Fin 1 → ℂ) ⊗[ℂ] (Fin 1 → ℂ) ≃ₗ[ℂ] ℂ := TensorProduct.congr (LinearEquiv.funUnique (Fin 1) ℂ ℂ) (LinearEquiv.funUnique (Fin 1) ℂ ℂ) ≪≫ₗ TensorProduct.lid ℂ ℂ @@ -434,6 +434,10 @@ private def lineTensorEquiv : 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 _ _) @@ -578,7 +582,7 @@ noncomputable instance : MonoidalPreadditive SmallSuperVect := /-- The even component of a unit endomorphism, at the scalar type. -/ -private def unitEvenMap (f : End (𝟙_ SuperVect)) : ℂ →ₗ[ℂ] ℂ := +def unitEvenMap (f : End (𝟙_ SuperVect)) : ℂ →ₗ[ℂ] ℂ := f.evenMap /-- **The scalar unit of `SuperVect`**: endomorphisms of the diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonExistence.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonExistence.lean index 810cfca1b6..566abb3116 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonExistence.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CanonExistence.lean @@ -230,6 +230,7 @@ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedAgreement.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedAgreement.lean index 53e17b5cf3..0fd5872013 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedAgreement.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedAgreement.lean @@ -230,6 +230,7 @@ theorem EdgeSubset.throughSummand_eq_mixedSummand 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] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueFold.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueFold.lean index b942345fb2..29445b503e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueFold.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueFold.lean @@ -213,7 +213,8 @@ def foldFlatten (i j : α) (ps : List (α × α)) /-! ### The fold: iterated single-pair gluing -/ -private noncomputable def glueListAux : +/-- 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) @@ -274,7 +275,8 @@ theorem glueList_cons {α : Type} (W : Fragment α) /-! ### Congruence: glueList respects fragment equivalence -/ -private noncomputable def glueListCongr_aux +/-- 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) @@ -303,7 +305,7 @@ noncomputable def glueListCongr {α : Type} (he : W₁.Equiv W₂) (ps : List (α × α)) (h : PairsWF ps) : (glueList W₁ ps h).Equiv (glueList W₂ ps h) := - glueListCongr_aux ps.length he ps h le_rfl + glueListCongrAux ps.length he ps h le_rfl /-! ### Relabelling commutes with the fold -/ @@ -775,7 +777,7 @@ 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)) := - (nonempty_glueList_relabel_aux ps.length W e ps hp le_rfl).some + (show Nonempty _ from by exact nonempty_glueList_relabel_aux ps.length W e ps hp le_rfl).some /-! ### Concatenation: folding in two stages -/ @@ -1131,7 +1133,8 @@ noncomputable def glueListAppend (W : Fragment α) (liftPairs ps qs h.append_sep) (liftPairs_wf ps qs h.append_right h.append_sep)).relabel (appendFlatten ps qs h.append_sep)) := - (nonempty_glueList_append_aux ps.length W ps qs h le_rfl).some + (show Nonempty _ from by + exact nonempty_glueList_append_aux ps.length W ps qs h le_rfl).some /-! ### Disjoint-union embedding: left -/ @@ -1656,8 +1659,9 @@ noncomputable def glueListDisjUnionLeft (((glueList W₁ ps hp).disjUnion W₂).relabel (inlFoldEquiv ps).symm) := - (nonempty_glueList_disjUnion_left_aux - ps.length W₁ W₂ ps hp le_rfl).some + (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 @@ -2060,8 +2064,9 @@ noncomputable def glueListSwap (swapPairs_wf ps hp)).Equiv ((glueList W ps hp).relabel (swapFoldEquiv ps).symm) := - (nonempty_glueList_swap_aux ps.length - W ps hp le_rfl).some + (show Nonempty _ from by + exact nonempty_glueList_swap_aux ps.length + W ps hp le_rfl).some /-! ### The reorder theorem -/ @@ -2330,7 +2335,8 @@ noncomputable def glueListPerm (W : Fragment α) {ps qs : List (α × α)} (glueList W ps hp).Equiv ((glueList W qs (hp.perm hperm)).relabel (foldSurvivingPermEquiv hperm).symm) := - (nonempty_glueList_perm W hperm hp).some + (show Nonempty _ from by + exact nonempty_glueList_perm W hperm hp).some end Fragment diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean index b758382424..f06bb2408e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean @@ -96,6 +96,7 @@ theorem chordPairCross_iff_xor [LinearOrder γ] 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 γ] @@ -126,6 +127,7 @@ theorem chordPairCross_parity [LinearOrder γ] · 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 @@ -137,6 +139,7 @@ private theorem inside_sum_eq [LinearOrder γ] 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 @@ -657,6 +660,7 @@ theorem chordCrossingCount_congr [LinearOrder α] {F : EdgeSubset W} (hpm : ∀ δ (hδ : δ ∈ F.boundaryFlags), κ'.pathMatch δ hδ = κ.pathMatch δ hδ) : chordCrossingCount κ' = chordCrossingCount κ := by + classical unfold chordCrossingCount exact congrArg Finset.card (Finset.filter_congr @@ -977,6 +981,7 @@ noncomputable def RelTransitionSystem.Orientation.flipOrbit 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 @@ -985,6 +990,7 @@ theorem flipOrbit_isOut_of_mem (o : κ.Orientation) {g : W.Flag} 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 From 5db6813e3610a4a1440622251ab26dff8ba2bba2 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Fri, 25 Sep 2026 21:14:05 +0000 Subject: [PATCH 31/46] Remove redundant Regts walk premises and local proofs --- .../Classical/Deligne/BaseChangeAdjoint.lean | 5 ---- .../RS/Classical/Deligne/InterchangeAct.lean | 15 +--------- .../RS/Classical/Deligne/SeedIns.lean | 14 --------- .../RS/Novel/Skein/GlueCircuitDelta.lean | 18 ++++-------- .../RS/Novel/Skein/OpenCircuits.lean | 29 ++++++++----------- .../RS/Novel/Skein/PathLedger.lean | 4 +-- .../RS/Novel/Skein/RelTransition.lean | 12 +++----- .../RS/Novel/Skein/TwoPathStep.lean | 12 +------- 8 files changed, 26 insertions(+), 83 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean index 7c4841849b..3545261194 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/BaseChangeAdjoint.lean @@ -278,11 +278,6 @@ theorem splitCoevalCoreDual_cover refine whisker_eq _ ?_ simp only [← MonoidalCategory.whiskerLeft_comp_assoc] rw [whisker_exchange_assoc] - have hbk : (B ◁ (modTensorπ A M' M ≫ d.pair ≫ φ)) ≫ μ[B] = - (β_ B (M'.X ⊗ M.X)).hom ≫ - ((modTensorπ A M' M ≫ d.pair ≫ φ) ▷ B) ≫ μ[B] := by - rw [← BraidedCategory.braiding_naturality_right_assoc, - IsCommMonObj.mul_comm] 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] = diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean index f43b999f63..ed2d1b9f2a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/InterchangeAct.lean @@ -81,20 +81,7 @@ theorem interchange_actLeft (modTensorAct A N₁ P₁ ▷ modTensor A N₂ P₂) ≫ modTensorπ A (modTensorMod A N₁ P₁) (modTensorMod A N₂ P₂) := by - have hTpin : (MonoidalCategory.whiskerLeft A - (Y₁ := 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₂)).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₂) - erw [MonoidalCategory.whiskerLeft_comp, Category.assoc, hTpin] + erw [MonoidalCategory.whiskerLeft_comp, Category.assoc, hT] repeat' erw [Category.assoc] conv_rhs => rw [associator_naturality_middle_assoc, associator_naturality_right_assoc, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean index 9626b9fe0f..6eb518497c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SeedIns.lean @@ -2227,20 +2227,6 @@ private theorem pairSeed_match (α_ M'.X (𝟙_ D) M.X).hom ≫ (M'.X ◁ (chainSeed A M M' d ▷ M.X)) := associator_naturality_middle _ _ _ - have hD10 : (chainSeed A M M' d ▷ M.X) ≫ - (β_ (chainStage2 A M M' 0 0) M.X).hom = - (β_ (𝟙_ D) M.X).hom ≫ (M.X ◁ chainSeed A M M' d) := - BraidedCategory.braiding_naturality_left _ _ - have hD11 : (M.X ◁ chainSeed A M M' d) ≫ - ((ρ_ M.X).inv ▷ (chainStage2 A M M' 0 0)) = - ((ρ_ M.X).inv ▷ (𝟙_ D)) ≫ - ((M.X ⊗ (𝟙_ D)) ◁ chainSeed A M M' d) := - whisker_exchange _ _ - have hD12 : ((M.X ⊗ (𝟙_ D)) ◁ chainSeed A M M' d) ≫ - (α_ M.X (𝟙_ D) (chainStage2 A M M' 0 0)).hom = - (α_ M.X (𝟙_ D) (𝟙_ D)).hom ≫ - (M.X ◁ ((𝟙_ D) ◁ chainSeed A M M' d)) := - associator_naturality_right _ _ _ have hSeed : chainSeed A M M' d ≫ chainDelta2 A M M' d 0 0 = (ρ_ (𝟙_ D)).inv ≫ ((𝟙_ D) ◁ chainSeed A M M' d) ≫ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean index 27733644ef..90afe4df56 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCircuitDelta.lean @@ -105,9 +105,7 @@ theorem periodicFlag_iterWalk (κ : F.RelTransitionSystem) /-- Reduce a walk index modulo a period. -/ theorem iterWalk_mod (κ : F.RelTransitionSystem) {f : W.Flag} - {n : ℕ} (_ : 1 ≤ n) - (hcont : ∀ t, t < n → - W.pairing (iterWalk κ f t) ∈ F.internalFlags) + {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 @@ -117,7 +115,7 @@ theorem iterWalk_mod (κ : F.RelTransitionSystem) {f : W.Flag} | 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 hcont] + 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] @@ -186,17 +184,15 @@ theorem RelTransitionSystem.pathMatch_congr κ.pathMatch b hb = κ.pathMatch b' hb' := by subst h; rfl -/-- Flags strictly inside a boundary-terminated chain segment are -not periodic. -/ +/-- 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 : ℕ} (hm1 : 1 ≤ m) (hmk : m ≤ k) : + {m : ℕ} (hmk : m ≤ k) : ¬ κ.PeriodicFlag (iterWalk κ b m) := by apply not_periodic_of_boundary_chain κ _ - (iterWalk_mem_internal κ k hm1 hmk hcont) refine ⟨(k - m) + 1, W.pairing (iterWalk κ (iterWalk κ b m) (k - m)), ?_⟩ apply traceChain_forward κ (iterWalk κ b m) (k := k - m) @@ -866,7 +862,7 @@ theorem splice_val_not_periodic : ∀ t, t < k → 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 : 1 ≤ t + 1) + (by rw [hterm]; exact hbo) (by omega : t + 1 ≤ k) hper omit hbo hyo hryx hterm in @@ -899,9 +895,7 @@ theorem splice_mod : ∀ c, iterWalk κ' (κ'.match_ x) c = iterWalk κ' (κ'.match_ x) (c % k) := by intro c - exact iterWalk_mod κ' hk1 - (splice_pairing_internal hij hopen s' hc' hc κ' x y b bo - hxb hyo hryx k hk1 hcont hterm) + exact iterWalk_mod κ' (splice_period hij hopen s' hc' hc κ' x y b bo hxb hyo hryx k hk1 hcont hterm) c diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/OpenCircuits.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/OpenCircuits.lean index 8e71206886..cf1d7faab8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/OpenCircuits.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OpenCircuits.lean @@ -70,12 +70,10 @@ theorem RelTransitionSystem.PeriodicFlag.mem_internal /-! #### Periodicity helpers -/ /-- Shift a period: `iterWalk κ f (n + k) = iterWalk κ f k` when -`iterWalk κ f n = f` and all intermediate pairings are internal. -/ +`iterWalk κ f n = f`. -/ theorem iterWalk_add_period (κ : F.RelTransitionSystem) (f : W.Flag) (n k : ℕ) - (hperiod : iterWalk κ f n = f) - (_hcont : ∀ j, j < n → - W.pairing (iterWalk κ f j) ∈ F.internalFlags) : + (hperiod : iterWalk κ f n = f) : iterWalk κ f (n + k) = iterWalk κ f k := by induction k with | zero => simp [hperiod] @@ -89,18 +87,18 @@ theorem all_pairings_internal_of_periodic (hper : κ.PeriodicFlag f) (j : ℕ) : W.pairing (iterWalk κ f j) ∈ F.internalFlags := by obtain ⟨_, n, hn1, hcont, hperiod⟩ := hper - have hmod : ∀ k, k < n → + have hmod : ∀ k, iterWalk κ f (n * (j / n) + k) = iterWalk κ f k := by - intro k _hkn + 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 hcont] + 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) (Nat.mod_lt j (by omega))] + rw [hmod (j % n)] exact hcont (j % n) (Nat.mod_lt j (by omega)) /-- All iterates along a periodic walk are internal. -/ @@ -176,15 +174,13 @@ 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 hfi := κ.periodicFlags_sub hf - have hgi := κ.periodicFlags_sub hg 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 hfi hgi hpf hpg h + exact κ.internalWalk_injOn hpf hpg h /-! ### 3. walkPermPeriodic -/ @@ -217,7 +213,7 @@ intermediate pairings internal), then it has period `d` from position 0. -/ theorem iterWalk_period_of_repeat (κ : F.RelTransitionSystem) (f : W.Flag) - (i d : ℕ) (_hd : 1 ≤ d) + (i d : ℕ) (hcont : ∀ j, j < i + d → W.pairing (iterWalk κ f j) ∈ F.internalFlags) (heq : iterWalk κ f i = iterWalk κ f (i + d)) : @@ -291,12 +287,12 @@ theorem periodic_of_allInternal 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) (by omega) + 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) (by omega) + iterWalk_period_of_repeat κ f j (i - j) (fun k _ => hcont_all k) (by rw [Nat.add_sub_cancel' hij.le]; exact heq.symm)⟩ @@ -360,7 +356,6 @@ theorem traceChain_none_of_all_internal_pairings /-- A flag whose chain reaches the boundary is not periodic. -/ theorem not_periodic_of_boundary_chain (κ : F.RelTransitionSystem) (f : W.Flag) - (_hf : f ∈ F.internalFlags) (hterm : ∃ fuel b, traceChain κ fuel f = some b) : ¬ κ.PeriodicFlag f := by intro hper @@ -406,12 +401,12 @@ theorem internal_periodic_or_terminates 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) (by omega) + 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) (by omega) + iterWalk_period_of_repeat κ f j (i - j) (fun k _ => hexall k) (by rw [Nat.add_sub_cancel' hij.le]; exact heq.symm)⟩ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean index f06bb2408e..635419181f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PathLedger.lean @@ -375,7 +375,7 @@ theorem chain_arg_ne_of_periodic {δ f : W.Flag} exact hpp.mem_internal | succ s => have hnp := not_periodic_of_chain_segment κ hcontδ htermδ - (by omega : 1 ≤ s + 1) (by omega : s + 1 ≤ kδ) + (by omega : s + 1 ≤ kδ) rw [h2] at hnp exact hnp hpp @@ -926,7 +926,7 @@ theorem orbitFlag_match {g f : W.Flag} (hg : κ.PeriodicFlag g) 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 hcont + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelTransition.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelTransition.lean index f452d675e9..e5e9c784b5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelTransition.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelTransition.lean @@ -200,20 +200,16 @@ noncomputable def RelTransitionSystem.internalWalk {F : EdgeSubset W} (κ : F.RelTransitionSystem) (f : W.Flag) : W.Flag := κ.match_ (W.pairing f) -/-- If the pairing of an internal flag is also internal, the walk -stays within internal flags. -/ +/-- If a flag's pairing is internal, its walk successor is internal. -/ theorem RelTransitionSystem.internalWalk_mem {F : EdgeSubset W} (κ : F.RelTransitionSystem) {f : W.Flag} - (_hf : f ∈ F.internalFlags) (hp : W.pairing f ∈ F.internalFlags) : κ.internalWalk f ∈ F.internalFlags := κ.match_mem _ hp -/-- The walk map is injective on internal flags (when pairings stay -internal). -/ +/-- The walk map is injective on flags whose pairings are internal. -/ theorem RelTransitionSystem.internalWalk_injOn {F : EdgeSubset W} (κ : F.RelTransitionSystem) {f g : W.Flag} - (_hf : f ∈ F.internalFlags) (_hg : g ∈ F.internalFlags) (hpf : W.pairing f ∈ F.internalFlags) (hpg : W.pairing g ∈ F.internalFlags) (h : κ.internalWalk f = κ.internalWalk g) : f = g := by @@ -242,7 +238,7 @@ 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 hf (κ.pairing_internal_of_allInternal hall hf) + κ.internalWalk_mem (κ.pairing_internal_of_allInternal hall hf) /-- When all flags are internal, the walk is injective. -/ theorem RelTransitionSystem.internalWalk_injOn_of_allInternal @@ -250,7 +246,7 @@ theorem RelTransitionSystem.internalWalk_injOn_of_allInternal (hall : F.allInternal) {f g : W.Flag} (hf : f ∈ F.internalFlags) (hg : g ∈ F.internalFlags) (h : κ.internalWalk f = κ.internalWalk g) : f = g := - κ.internalWalk_injOn hf hg + κ.internalWalk_injOn (κ.pairing_internal_of_allInternal hall hf) (κ.pairing_internal_of_allInternal hall hg) h diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathStep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathStep.lean index baaea89dd9..467450978b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathStep.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathStep.lean @@ -52,14 +52,7 @@ theorem not_periodic_of_onBoundaryChain {β f : W.Flag} intro hper obtain ⟨k, t, htk, hcont, hterm, hft⟩ := h rcases hft with rfl | rfl - · cases t with - | zero => - rw [iterWalk_zero] at hper - exact Finset.disjoint_left.mp - F.internalFlags_disjoint_boundaryFlags hper.mem_internal hβ - | succ t => - exact not_periodic_of_chain_segment κ hcont hterm - (by omega) htk hper + · 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 @@ -221,8 +214,6 @@ theorem not_periodic_repair_of_tail (hsq : RepairSquare κ a b c d v) W.pairing (iterWalk κ β j) ≠ d) : ¬ (κ.repair a b c d v hsq).PeriodicFlag (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 @@ -236,7 +227,6 @@ theorem not_periodic_repair_of_tail (hsq : RepairSquare κ a b c d v) 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) _ - hYint refine ⟨(k - s - 1) + 1, W.pairing (iterWalk (κ.repair a b c d v hsq) (iterWalk κ β (s + 1)) (k - s - 1)), ?_⟩ From ff335a09f701777788e40039160edb3cd1616c98 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Fri, 25 Sep 2026 21:20:59 +0000 Subject: [PATCH 32/46] Remove unused duplicate disjoint-union helper block --- .../RS/Novel/Skein/DisjUnionProduct.lean | 912 ------------------ 1 file changed, 912 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean index 1d01ffbc2e..a3ecd68950 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean @@ -81,918 +81,6 @@ theorem mem_internalFlags_iff {γ : Type} {W : Fragment γ} ∃ v : W.Vertex, W.attach f = Sum.inl v := Finset.mem_filter -section SumToolbox - -variable {α β : Type} {W₁ : Fragment α} {W₂ : Fragment β} - -/-! ## Attachment over the union (mirrors `DisjSubsetSplit`) -/ - -/-- 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⟩ - -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} - -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 -/ - -/-- The left component of a union system's match on a left flag, -chosen arbitrarily off the internal flags. -/ -noncomputable def leftDescend (κ : F.RelTransitionSystem) - (g : W₁.Flag) : W₁.Flag := - Sum.elim id (fun _ => g) (κ.match_ (Sum.inl g)) - -/-- The right component of a union system's match on a right flag, -chosen arbitrarily off the internal flags. -/ -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 - -/-! ### Circuit count additivity -/ - -/-- 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 - -end ProdSystems -/-! ## The through-product factorization -/ - -section ThroughSplit - -open EdgeSubset - -variable {α β : Type} - -end ThroughSplit -/-! ## Componentwise colourings -/ - -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 - -end ColourSplit /-! ## The canonical-value migration The corrected (canonical) constrained value pins a path-canonical From 1c5b701ccd6a5d421c7e6af95b9279523dabd213 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Fri, 25 Sep 2026 21:45:56 +0000 Subject: [PATCH 33/46] Repair Regts module interfaces and local proof scopes --- .../Deligne/PointMonoidal/Coherence.lean | 6 --- .../Interfaces/SectorIntertwine.lean | 2 +- .../RS/Novel/Coordinates/BlockSigma.lean | 6 +-- .../RS/Novel/Coordinates/CapPeel.lean | 4 +- .../RS/Novel/Coordinates/StarPeel.lean | 4 +- .../RS/Novel/Envelope/BlockSplice.lean | 42 +++++++++---------- .../RS/Novel/Envelope/MatEmbMonoidal.lean | 12 +++--- .../RS/Novel/Skein/AllInternalAgreement.lean | 2 + .../RS/Novel/Skein/CloseRotate.lean | 8 ++-- .../RS/Novel/Skein/CloseRotateLeft.lean | 25 +++++------ .../RS/Novel/Skein/ComposeAssoc.lean | 12 +++--- .../RS/Novel/Skein/ComposeNormal.lean | 14 +++++-- .../RS/Novel/Skein/DisjUnionFactor/A.lean | 27 ++++++------ .../RS/Novel/Skein/OrbitParities.lean | 3 +- .../RS/Novel/Skein/PairCloseComm.lean | 29 ++++++------- .../RS/Novel/Skein/PairingSignature.lean | 1 + .../RS/Novel/Skein/PartialCloseTensor.lean | 4 +- .../RS/Novel/Skein/RelabelInvariance.lean | 1 + .../RS/Novel/Skein/SeparatedParity.lean | 9 ++-- .../RS/Novel/Skein/SnakeClasses.lean | 8 ++-- .../RS/Novel/Skein/StarExplode.lean | 2 +- .../RS/Novel/Skein/TensorIdeal.lean | 7 ++-- .../RS/Novel/Skein/TensorInterchange.lean | 6 +-- .../RS/Novel/Skein/TwoPathNonSep.lean | 12 ++++++ 24 files changed, 136 insertions(+), 110 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean index 41c1c34648..34295c5e76 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/PointMonoidal/Coherence.lean @@ -103,7 +103,6 @@ private theorem superVectMu_associativity_evenMap svWhiskerRight_evenMap_inl, svWhiskerLeft_evenMap_inl, svAssoc_evenMap_ee, - superVectMu_evenMap_ee, superVectHom_evenMap_apply, LinearEquiv.symm_apply_apply] @@ -126,7 +125,6 @@ private theorem superVectMu_associativity_evenMap svWhiskerRight_evenMap_inl, svWhiskerLeft_evenMap_inr, svAssoc_evenMap_oo, - superVectMu_evenMap_ee, superVectMu_evenMap_oo, superVectMu_oddMap_oe, superVectHom_evenMap_apply, @@ -150,7 +148,6 @@ private theorem superVectMu_associativity_evenMap svWhiskerRight_evenMap_inr, svWhiskerLeft_evenMap_inl, svAssoc_evenMap_eo, - superVectMu_evenMap_oo, superVectMu_oddMap_eo, superVectHom_evenMap_apply, @@ -174,7 +171,6 @@ private theorem superVectMu_associativity_evenMap simp only [svComp_evenMap_apply, svWhiskerRight_evenMap_inr, svWhiskerLeft_evenMap_inr, - svAssoc_evenMap_oe, superVectMu_evenMap_oo, superVectMu_oddMap_eo, superVectMu_oddMap_oe, @@ -270,7 +266,6 @@ private theorem superVectMu_associativity_oddMap simp only [ svComp_oddMap_apply, svWhiskerRight_oddMap_inr, svWhiskerLeft_oddMap_inl, - svAssoc_oddMap_eo, superVectMu_oddMap_eo, superVectMu_oddMap_oe, superVectHom_oddMap_apply, @@ -293,7 +288,6 @@ private theorem superVectMu_associativity_oddMap simp only [ svComp_oddMap_apply, svWhiskerRight_oddMap_inr, svWhiskerLeft_oddMap_inr, - svAssoc_oddMap_oe, superVectMu_evenMap_ee, superVectMu_oddMap_oe, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorIntertwine.lean b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorIntertwine.lean index 199e20a59b..98b6f8b798 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorIntertwine.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Interfaces/SectorIntertwine.lean @@ -109,7 +109,7 @@ theorem oddInversions_allEvenEmb (k ℓ n : ℕ) /-! ## Colour-model basis vectors -/ /-- A basis vector of the even colour model at an even colouring. -/ -private noncomputable def evenBasis (k ℓ n : ℕ) +noncomputable def evenBasis (k ℓ n : ℕ) (c : {c : MixedColouring k ℓ n // c.IsEven}) : (superPow (stdSuperPair k ℓ) n).even := (colourPowerEquiv k ℓ n).evenEquiv.symm diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSigma.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSigma.lean index 17bf20000b..ca03f955a2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSigma.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockSigma.lean @@ -20,21 +20,21 @@ block to enumerate the concatenated total. namespace RS /-- Split the sigma over a cons list into head + tail. -/ -private def blockSigmaSplitFun (d : ℕ) (ds : List ℕ) : +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. -/ -private def blockSigmaSplitInv (d : ℕ) (ds : List ℕ) : +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. -/ -private def blockSigmaSplit (d : ℕ) (ds : List ℕ) : +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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeel.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeel.lean index 98c5f4270c..5572ba887c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeel.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeel.lean @@ -429,8 +429,8 @@ noncomputable def capPeelEquiv (m : ℕ) : show Empty ≃ (Empty ⊕ Empty) from _root_.Equiv.equivOfIsEmpty _ _ -- ═══════ ATTACHMENT ═══════ - attach_comm := capPeelEquiv_attach_comm m - pairing_comm := capPeelEquiv_pairing_comm m + attach_comm := by exact capPeelEquiv_attach_comm m + pairing_comm := by exact capPeelEquiv_pairing_comm m circles_eq := rfl variable {R : ℕ} (f : EdgeRankParameter R) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPeel.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPeel.lean index f2386f519c..b33886ef14 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPeel.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPeel.lean @@ -346,8 +346,8 @@ noncomputable def multiStarPeel {n : ℕ} (d S c : ℕ) -- ═══════ ATTACHMENT ═══════ -- Flags below `d` sit on the peeled star, the rest on the -- remaining ones; each side keeps its own vertex. - attach_comm := multiStarPeel_attach_comm d S c rest a ha_low ha_high - pairing_comm := multiStarPeel_pairing_comm d S c rest a + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockSplice.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockSplice.lean index e20d8b8f7c..11dc97aa49 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockSplice.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockSplice.lean @@ -73,7 +73,7 @@ private theorem blockRot_symm_val (a b : ℕ) (x : Fin (a + b)) : /-- 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`. -/ -private def blockOuterPerm (K n : ℕ) : +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⟩ @@ -191,7 +191,7 @@ private theorem block_label_val (K n : ℕ) /-- 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. -/ -private def blockSpliceFlagEquiv (K n : ℕ) : +def blockSpliceFlagEquiv (K n : ℕ) : (Fin (K + n + n) × Bool) ≃ ((Fin (n + n) × Bool) ⊕ (Fin K × Bool)) where toFun p := @@ -320,7 +320,7 @@ private theorem block_ER_val (K n : ℕ) /-! ### Collapsing a value-identity recast -/ /-- Collapse a value-identity recast. -/ -private noncomputable def relabel_defeq_collapse {a : ℕ} +noncomputable def relabelDefeqCollapse {a : ℕ} (F : Fragment (Fin a)) (p : a = a) : (F.relabel (finCongr p)).Equiv F := (Fragment.Equiv.relabelEq F @@ -328,7 +328,7 @@ private noncomputable def relabel_defeq_collapse {a : ℕ} (Fragment.Equiv.relabelRefl F) /-- Composition against an outer-boundary recast. -/ -private noncomputable def compose_relabel_castOut +noncomputable def composeRelabelCastOut {s t u u' : ℕ} (h : u = u') (F : Fragment (Fin (s + t))) (G : Fragment (Fin (t + u))) : (F.compose (G.relabel @@ -337,8 +337,8 @@ private noncomputable def compose_relabel_castOut (finCongr (by rw [h] : s + u = s + u'))) := by cases h exact (Fragment.composeCongr (Fragment.Equiv.refl F) - (relabel_defeq_collapse G _)).trans - (relabel_defeq_collapse (F.compose G) _).symm + (relabelDefeqCollapse G _)).trans + (relabelDefeqCollapse (F.compose G) _).symm /-! ### The bridge: the rotation as through-strands and cups -/ @@ -629,7 +629,7 @@ private theorem blockSpliceFlagEquiv_pairing (K n : ℕ) /-- **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. -/ -private noncomputable def block_bridge (K n : ℕ) : +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 @@ -648,9 +648,9 @@ private noncomputable def block_bridge (K n : ℕ) : ⟨fun x => x.elim Empty.elim Empty.elim⟩ show (Empty : Type) ≃ (Empty ⊕ Empty : Type) from _root_.Equiv.equivOfIsEmpty _ _ - attach_comm := block_bridge_attach_comm K n - pairing_comm := fun f => - blockSpliceFlagEquiv_pairing K n f.1 f.2 + 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 -/ @@ -658,7 +658,7 @@ private noncomputable def block_bridge (K n : ℕ) : /-- The reshuffle decomposition: the reshuffled big block rotation is the through-strands tensored with K cups, up to the outer boundary permutation. -/ -private noncomputable def block_reshuffle_decomp (K n : ℕ) : +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) @@ -676,13 +676,13 @@ private noncomputable def block_reshuffle_decomp (K n : ℕ) : ((Fragment.Equiv.relabelTrans (strandBundle (K + n + n)) (permHighEquiv (blockRot (K + n) n).symm) (pcReshuffle (K + n) (K + n) n n)).trans - (block_bridge K n)) + (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. -/ -private def blockFinalFlagEquiv (K n : ℕ) +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) @@ -915,7 +915,7 @@ private theorem block_splice_bridge_circles (K n : ℕ) /-- The last comparison of the block splice: the leg-extended tensor against the rotated through-tensor. -/ -private noncomputable def block_splice_bridge (K n : ℕ) +noncomputable def blockSpliceBridge (K n : ℕ) (𝔊 : Fragment (Fin (n + n))) : ((tensorFragment (s := 0) (t := n + n) (u := 0) (v := K + K) (𝔊.relabel @@ -937,12 +937,12 @@ private noncomputable def block_splice_bridge (K n : ℕ) show (𝔊.Vertex ⊕ (Empty : Type)) ≃ ((Empty : Type) ⊕ 𝔊.Vertex) from _root_.Equiv.sumComm _ _ - attach_comm := block_splice_bridge_attach_comm K n 𝔊 + attach_comm := by exact block_splice_bridge_attach_comm K n 𝔊 pairing_comm := by rintro (g | ⟨k, c⟩) · rfl · rfl - circles_eq := block_splice_bridge_circles K n 𝔊 + circles_eq := by exact block_splice_bridge_circles K n 𝔊 /-! ### The splice -/ @@ -963,7 +963,7 @@ noncomputable def partialCloseBlockSplice (K n : ℕ) refine (Fragment.Equiv.relabelCongr (Fragment.composeCongr (Fragment.Equiv.refl _) - (block_reshuffle_decomp K n)) + (blockReshuffleDecomp K n)) (finCongr (by omega : 0 + ((K + n) + (K + n)) = (K + n) + (K + n)))).trans ?_ -- Step 3: composeRelabelOut (absorb outer perm into composition) @@ -980,10 +980,10 @@ noncomputable def partialCloseBlockSplice (K n : ℕ) (n + n) + ((K + n) + (K + n)))))) (finCongr (by omega : 0 + ((K + n) + (K + n)) = (K + n) + (K + n)))).trans ?_ - -- Step 4: compose_relabel_castOut (collapse the recast) + -- Step 4: composeRelabelCastOut (collapse the recast) refine (Fragment.Equiv.relabelCongr (Fragment.Equiv.relabelCongr - (compose_relabel_castOut + (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) @@ -1008,7 +1008,7 @@ noncomputable def partialCloseBlockSplice (K n : ℕ) (Fragment.composeCongr ((tensorFragmentUnitRight (𝔊.relabel (finCongr (by omega : n + n = 0 + (n + n))))).trans - (relabel_defeq_collapse _ _)).symm + (relabelDefeqCollapse _ _)).symm (Fragment.Equiv.refl _)).trans ((Fragment.tensorComposeInterchange (𝔊.relabel @@ -1044,6 +1044,6 @@ noncomputable def partialCloseBlockSplice (K n : ℕ) ((tensorFragment (strandBundle K) 𝔊).relabel (transposeEquiv (K + n) (K + n)))).trans (Fragment.Equiv.relabelTrans _ _ _)).symm - exact block_splice_bridge K n 𝔊 + exact blockSpliceBridge K n 𝔊 end RS diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean index 796af80460..030ce81c6d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean @@ -400,17 +400,17 @@ private theorem matEmb_right_unitality `ε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`. -/ -private noncomputable def matEmbCoreMonoidal +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 := matEmb_μ_natural_left - μIso_hom_natural_right := matEmb_μ_natural_right - associativity := matEmb_associativity - left_unitality := matEmb_left_unitality - right_unitality := matEmb_right_unitality + μ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`. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalAgreement.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalAgreement.lean index e458b5ee5d..3ed227140d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalAgreement.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/AllInternalAgreement.lean @@ -56,6 +56,7 @@ 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 @@ -250,6 +251,7 @@ theorem openCircuitCount_toRel (κ : F.TransitionSystem) : /-! ## 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 α] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotate.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotate.lean index 8508c7dc0f..1457a7978c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotate.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotate.lean @@ -931,8 +931,8 @@ noncomputable def rotateNormalLeft {m n 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) := - lhsQs2_wf m n p + 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)) @@ -1139,8 +1139,8 @@ noncomputable def rotateNormalRight {m n p : ℕ} 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) := - rotQ4_wf m n p + 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotateLeft.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotateLeft.lean index 4342cec74b..29fc408ed7 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotateLeft.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CloseRotateLeft.lean @@ -721,8 +721,8 @@ noncomputable def leftRotNormalRight (leftRotQ3 s t u) := Fragment.mapPairs_wf i'.symm _ wfq2 let wfq4 : Fragment.PairsWF - (leftRotQ4 s t u) := - leftRotQ4_wf s t u + (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) @@ -875,7 +875,7 @@ noncomputable def leftRotNormalRight /-- Swapping each pair in a liftPairs list amounts to lifting the swapped suffix. -/ -private theorem liftPairs_map_swap +theorem leftRotate_liftPairs_map_swap {α : Type} (ps : List (α × α)) : ∀ (qs : List (α × α)) @@ -891,11 +891,11 @@ private theorem liftPairs_map_swap congrArg₂ List.cons (Prod.ext (Subtype.ext rfl) (Subtype.ext rfl)) - (liftPairs_map_swap ps qs _ _) + (leftRotate_liftPairs_map_swap ps qs _ _) /-- Permutation from rotatePairsL to the intermediate form mBlock ++ (pBlock ++ nBlock). -/ -private theorem leftRotPairs_perm +theorem leftRotatePairs_perm (s t u : ℕ) : (nBlock s t u ++ (pBlock s t u ++ @@ -1011,10 +1011,11 @@ theorem leftRot_surv_empty (s t u : ℕ) /-! ### The final theorem -/ -private theorem leftRotPairs_assoc_wf (s t u : ℕ) : +/-- 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 (leftRotPairs_perm s t u) + (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 @@ -1044,7 +1045,7 @@ noncomputable def pairCloseComposeRotateLeft (pBlock s t u ++ nBlock s t u)) := (rotatePairsL_wf s t u).perm - (leftRotPairs_perm s t u) + (leftRotatePairs_perm s t u) have hassocM : mBlock s t u ++ (pBlock s t u ++ nBlock s t u) = @@ -1052,8 +1053,8 @@ noncomputable def pairCloseComposeRotateLeft (List.append_assoc _ _ _).symm have wf_MA : Fragment.PairsWF - (mp ++ nBlock s t u) := - leftRotPairs_assoc_wf s t u + (mp ++ nBlock s t u) := by + exact leftRotatePairs_assoc_wf s t u have hassocR : mp ++ nBlockSwap s t u = mBlock s t u ++ @@ -1080,7 +1081,7 @@ noncomputable def pairCloseComposeRotateLeft wf_RA.append_right wf_RA.append_sep have lPeq := - liftPairs_map_swap mp (nBlock s t u) + 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) @@ -1153,7 +1154,7 @@ noncomputable def pairCloseComposeRotateLeft (hnb ▸ List.Perm.refl _))).trans ((Fragment.Equiv.relabelCongr ((Fragment.glueListPerm A - (leftRotPairs_perm s t u) + (leftRotatePairs_perm s t u) (rotatePairsL_wf s t u)).trans ((Fragment.Equiv.relabelCongr suffix_swap _).trans diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeAssoc.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeAssoc.lean index ddbfd691e2..1cdd865faf 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeAssoc.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeAssoc.lean @@ -728,8 +728,8 @@ noncomputable def assocNormalLeft {s t 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'' := - lhsOuterPairs_wf s t 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)) @@ -938,12 +938,12 @@ noncomputable def assocNormalRight {s t u v : ℕ} (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) := - rhsQs1_wf s t u v + 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) := - rhsQs3_wf s t u v + 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' := diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeNormal.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeNormal.lean index d59a645900..5b91123351 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeNormal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ComposeNormal.lean @@ -449,7 +449,7 @@ noncomputable def glueInterfaceNormal (s u : ℕ) : (tailPairs s t u) hwf_cons.sep (Sum.inl ⟨s + (a.val - s), by omega⟩, Sum.inr ⟨a.val - s, by omega⟩) - (mem_tailPairs s t u (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 @@ -486,7 +486,7 @@ noncomputable def glueInterfaceNormal (s u : ℕ) : (tailPairs s t u) hwf_cons.sep (Sum.inl ⟨s + b.val, by omega⟩, Sum.inr ⟨b.val, by omega⟩) - (mem_tailPairs s t u b.val h) + (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' @@ -530,10 +530,16 @@ noncomputable def glueInterfaceNormal (s u : ℕ) : (Fragment.Equiv.relabelTrans _ _ _) ?_ have heqG : (Fragment.foldSurvivingPermEquiv (by rw [interfacePairs_succ s t u] : - (interfacePairs s (t + 1) u).Perm _)).trans + (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 _)).symm.trans + (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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean index bf2b71a8b0..4a6b242846 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean @@ -37,6 +37,7 @@ 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 ∧ @@ -455,24 +456,26 @@ variable {α β : Type} {W₁ : Fragment α} {W₂ : Fragment β} /-! ### Restriction to the components -/ -private noncomputable def leftDescend (κ : F.RelTransitionSystem) +/-- Restrict a union matching to a left flag, fixing it if the image lies on the right. -/ +noncomputable def factorLeftDescend (κ : F.RelTransitionSystem) (g : W₁.Flag) : W₁.Flag := Sum.elim id (fun _ => g) (κ.match_ (Sum.inl g)) -private noncomputable def rightDescend (κ : F.RelTransitionSystem) +/-- Restrict a union matching to a right flag, fixing it if the image lies on the left. -/ +noncomputable def factorRightDescend (κ : F.RelTransitionSystem) (g : W₂.Flag) : W₂.Flag := Sum.elim (fun _ => g) id (κ.match_ (Sum.inr g)) private theorem leftDescend_spec (κ : F.RelTransitionSystem) {g : W₁.Flag} (hg : g ∈ (leftSub F).internalFlags) : - κ.match_ (Sum.inl g) = Sum.inl (leftDescend κ g) := by + κ.match_ (Sum.inl g) = Sum.inl (factorLeftDescend κ 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 + · unfold factorLeftDescend rw [hm] rfl · rw [hm] at hvert @@ -480,7 +483,7 @@ private theorem leftDescend_spec (κ : F.RelTransitionSystem) private theorem rightDescend_spec (κ : F.RelTransitionSystem) {g : W₂.Flag} (hg : g ∈ (rightSub F).internalFlags) : - κ.match_ (Sum.inr g) = Sum.inr (rightDescend κ g) := by + κ.match_ (Sum.inr g) = Sum.inr (factorRightDescend κ 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 @@ -489,20 +492,20 @@ private theorem rightDescend_spec (κ : F.RelTransitionSystem) rcases hm : κ.match_ (Sum.inr g) with g' | g' · rw [hm] at hvert exact absurd hvert attach_inl_ne_inr - · unfold rightDescend + · unfold factorRightDescend rw [hm] rfl private theorem leftDescend_mem (κ : F.RelTransitionSystem) {g : W₁.Flag} (hg : g ∈ (leftSub F).internalFlags) : - leftDescend κ g ∈ (leftSub F).internalFlags := by + factorLeftDescend κ 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 private theorem rightDescend_mem (κ : F.RelTransitionSystem) {g : W₂.Flag} (hg : g ∈ (rightSub F).internalFlags) : - rightDescend κ g ∈ (rightSub F).internalFlags := by + factorRightDescend κ 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 @@ -512,7 +515,7 @@ component: the matching never crosses between components, so it restricts. -/ noncomputable def leftRel (κ : F.RelTransitionSystem) : (leftSub F).RelTransitionSystem where - match_ := leftDescend κ + match_ := factorLeftDescend κ match_invol g hg := by have h := κ.match_invol _ (inl_mem_internal.mpr hg) rw [leftDescend_spec κ hg, @@ -522,7 +525,7 @@ noncomputable def leftRel (κ : F.RelTransitionSystem) : have h := κ.match_ne _ (inl_mem_internal.mpr hg) rw [leftDescend_spec κ hg, heq] at h exact h rfl - match_mem g hg := leftDescend_mem κ hg + 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) @@ -532,7 +535,7 @@ noncomputable def leftRel (κ : F.RelTransitionSystem) : /-- The restriction to the right component. -/ noncomputable def rightRel (κ : F.RelTransitionSystem) : (rightSub F).RelTransitionSystem where - match_ := rightDescend κ + match_ := factorRightDescend κ match_invol g hg := by have h := κ.match_invol _ (inr_mem_internal.mpr hg) rw [rightDescend_spec κ hg, @@ -542,7 +545,7 @@ noncomputable def rightRel (κ : F.RelTransitionSystem) : have h := κ.match_ne _ (inr_mem_internal.mpr hg) rw [rightDescend_spec κ hg, heq] at h exact h rfl - match_mem g hg := rightDescend_mem κ hg + 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrbitParities.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrbitParities.lean index c5fb38a206..3958600b20 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrbitParities.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrbitParities.lean @@ -97,11 +97,12 @@ private theorem sameCycle_swap_mul_pow_left [DecidableEq Y] /-- `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 [Fintype Y] [DecidableEq Y] +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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairCloseComm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairCloseComm.lean index a10f8082fd..b90d5b5104 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairCloseComm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairCloseComm.lean @@ -22,7 +22,8 @@ namespace RS namespace Fragment -private def pcSwapFun (t : ℕ) : +/-- 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 @@ -31,19 +32,19 @@ private def pcSwapFun (t : ℕ) : /-- Self-inverse sum-swap equivalence used in the `pairClose` commutativity proof. -/ -private def pairCloseSwap (t : ℕ) : +def pairCloseSwap (t : ℕ) : Fin (0 + t) ⊕ Fin (t + 0) ≃ Fin (0 + t) ⊕ Fin (t + 0) where - toFun := pcSwapFun t - invFun := pcSwapFun t + toFun := pairCloseSwapFun t + invFun := pairCloseSwapFun t left_inv x := by - rcases x with a | b <;> simp [pcSwapFun, finCongr] + rcases x with a | b <;> simp [pairCloseSwapFun, finCongr] right_inv x := by - rcases x with a | b <;> simp [pcSwapFun, finCongr] + rcases x with a | b <;> simp [pairCloseSwapFun, finCongr] /-- The disjoint-union ambients of `pairClose F G` and `pairClose G F` are related by `pairCloseSwap`. -/ -private noncomputable def pairCloseAmbient +noncomputable def pairCloseAmbient {t : ℕ} (F G : Fragment (Fin t)) : (disjUnion (F.relabel (finCongr (by omega : t = 0 + t))) @@ -91,7 +92,7 @@ private noncomputable def pairCloseAmbient /-- `mapPairs` through `(pairCloseSwap t).symm` on the interface pairs yields the swap of each pair. -/ -private theorem mapPairs_pcs_symm (t : ℕ) : +theorem mapPairs_pairCloseSwap_symm (t : ℕ) : mapPairs (pairCloseSwap t).symm (interfacePairs 0 t 0) = (interfacePairs 0 t 0).map Prod.swap := by @@ -100,12 +101,12 @@ private theorem mapPairs_pcs_symm (t : ℕ) : refine congrArg List.reverse (List.map_congr_left fun k _ => ?_) -- Each pair: (Sum.inl ⟨0+k, _⟩, Sum.inr ⟨k, _⟩) - -- .symm acts as pcSwapFun since self-inverse - change (pcSwapFun t (Sum.inl ⟨0 + k.val, _⟩), - pcSwapFun t (Sum.inr ⟨k.val, _⟩)) = + -- .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 [pcSwapFun, Sum.elim_inl, + simp only [pairCloseSwapFun, Sum.elim_inl, Sum.elim_inr] exact Prod.ext (congrArg Sum.inr (Fin.ext (by simp))) @@ -152,8 +153,8 @@ noncomputable def pairCloseComm {t : ℕ} -- 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 := - mapPairs_pcs_symm t + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSignature.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSignature.lean index cbcd92df46..2e373685c3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSignature.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairingSignature.lean @@ -38,6 +38,7 @@ theorem chordCross_of_samePairing 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} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean index bdee3dea67..778d7e3910 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean @@ -358,8 +358,8 @@ noncomputable def pcTensorNormal {s t u v : ℕ} (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 := - pcTensorQs_wf s t u v + have wfqsP : Fragment.PairsWF qsP := by + exact pcTensorQs_wf s t u v let shufE := sumShuffleEquiv (Fin (u + v)) (Fin (s + t)) (Fin (u + v)) let ps₂ := Fragment.inrPairs (α := Fin (s + t)) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelInvariance.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelInvariance.lean index 94ae11aad1..e663f0de75 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelInvariance.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RelabelInvariance.lean @@ -503,6 +503,7 @@ theorem relabel_throughProduct /-! ## 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SeparatedParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SeparatedParity.lean index 3e9c7b43ba..591c153214 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SeparatedParity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SeparatedParity.lean @@ -128,10 +128,11 @@ private theorem swap_mul_pow_eq [DecidableEq Y] /-- **Untouched orbits**: `SameCycle` from a point in neither swapped orbit transfers across the swap-multiplication. -/ -theorem sameCycle_swap_mul_iff [Fintype Y] [DecidableEq Y] +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) @@ -221,10 +222,11 @@ private theorem swap_mul_support_subset [Fintype Y] [DecidableEq Y] /-- **No crossover**: swapping two points of one cycle separates them. -/ -private theorem not_sameCycle_swap_mul [Fintype Y] [DecidableEq Y] +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⟩ @@ -280,10 +282,11 @@ private theorem not_sameCycle_swap_mul [Fintype Y] [DecidableEq Y] /-- **Merging**: swapping two points of different orbits joins them. -/ -theorem sameCycle_swap_mul_of_not [Fintype Y] [DecidableEq Y] +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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SnakeClasses.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SnakeClasses.lean index 12fa182769..5a46896f88 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SnakeClasses.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SnakeClasses.lean @@ -73,7 +73,7 @@ noncomputable def snakeFragLEquiv : flagEquiv := _root_.Equiv.ofBijective (fun g : Fin 1 × Bool => snakeFragL.boundaryFlag (if g.2 then 1 else 0)) - ((Fintype.bijective_iff_injective_and_card _).mpr + (by exact (Fintype.bijective_iff_injective_and_card _).mpr ⟨by intro a b h obtain ⟨i, ba⟩ := a @@ -92,7 +92,7 @@ noncomputable def snakeFragLEquiv : · exact absurd h (by decide) · rfl, by decide⟩) - vertexEquiv := _root_.Equiv.equivOfIsEmpty _ _ + 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 @@ -115,7 +115,7 @@ noncomputable def snakeFragREquiv : flagEquiv := _root_.Equiv.ofBijective (fun g : Fin 1 × Bool => snakeFragR.boundaryFlag (if g.2 then 1 else 0)) - ((Fintype.bijective_iff_injective_and_card _).mpr + (by exact (Fintype.bijective_iff_injective_and_card _).mpr ⟨by intro a b h obtain ⟨i, ba⟩ := a @@ -134,7 +134,7 @@ noncomputable def snakeFragREquiv : · exact absurd h (by decide) · rfl, by decide⟩) - vertexEquiv := _root_.Equiv.equivOfIsEmpty _ _ + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarExplode.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarExplode.lean index 1252abb924..c3b48fb662 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StarExplode.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StarExplode.lean @@ -399,7 +399,7 @@ noncomputable def explodeAtGluePair (W : ClosedFragment) · rfl · rfl -- ═══════ PAIRING ═══════ - pairing_comm := explodeAt_rewire_pairing W C hC f₀ h₀ hopen + pairing_comm := by exact explodeAt_rewire_pairing W C hC f₀ h₀ hopen } end GlueStep diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorIdeal.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorIdeal.lean index 8231b1cb27..4552cc5142 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorIdeal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorIdeal.lean @@ -768,7 +768,8 @@ noncomputable def absLabelL (s t u v : ℕ) : ((interfaceSurvEquiv 0 ((s + u) + (t + v)) 0).trans finSumFinEquiv)))))))))) -private theorem absPs0_wf (s t u v : ℕ) : +/-- 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 @@ -809,8 +810,8 @@ noncomputable def absNormalLeft {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) := - absPs0_wf s t u v + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean index 2bf1659422..6598ca1b7e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean @@ -731,12 +731,12 @@ noncomputable def interchangeNormalRight have L2B := Equiv.relabelFlip' (glueListEqEquiv ((GL₁.disjUnion (F₂.disjUnion G₂)).relabel e_l) - (liftPairs_inlPairs_inrPairs ips₁ ips₂ wf_lr.append_sep) + (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 - (liftPairs_inlPairs_inrPairs ips₁ ips₂ + (by exact liftPairs_inlPairs_inrPairs ips₁ ips₂ wf_lr.append_sep))) -- L2R: peel e_l through second-stage glueList have L2R := glueListRelabel @@ -774,7 +774,7 @@ noncomputable def interchangeNormalRight (tensorFragment G₁ G₂)).trans ((Equiv.relabelCongr C_total surv_c).trans ((Equiv.relabelTrans _ _ _).trans - (Equiv.relabelEq _ (interchange_survivor_relabel_eq _ + (Equiv.relabelEq _ (by exact interchange_survivor_relabel_eq _ (fun x => by cases x <;> rfl))))) /-! ### Final assembly -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathNonSep.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathNonSep.lean index 53dc13ac62..ce91f9e34a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathNonSep.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TwoPathNonSep.lean @@ -36,6 +36,7 @@ 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} @@ -49,16 +50,19 @@ 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₂) := @@ -79,6 +83,7 @@ theorem stateOddFlip_right_odd {c : Fin (2 * ℓ)} 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) ↔ @@ -97,6 +102,7 @@ theorem stateOddFlip_isInr (i : α) : 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 @@ -121,6 +127,7 @@ theorem genBoundarySubsetMatches_stateOddFlip {W : Fragment α} 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 @@ -692,10 +699,12 @@ private theorem inb_portFlip (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) /-! ### 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 @@ -1126,6 +1135,7 @@ private theorem inSign_pin₂ (h : PortedFlipSet κ S p₁ p₂ i₁ i₂) /-! ### 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₁) @@ -1205,6 +1215,7 @@ private theorem throughProduct_eq_body [LinearOrder α] 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} @@ -1281,6 +1292,7 @@ private theorem throughProduct_stateOddFlip [LinearOrder α] /-! ### 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 From 9c5aae16e176317a59313b9578983f1ef4895ef5 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Fri, 25 Sep 2026 21:48:43 +0000 Subject: [PATCH 34/46] Preserve shared disjoint-union helper interfaces --- .../RS/Novel/Skein/DisjUnionFactor/A.lean | 58 ++++--- .../RS/Novel/Skein/DisjUnionFactor/B.lean | 149 +++++++++++++----- 2 files changed, 148 insertions(+), 59 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean index 4a6b242846..5a5a966662 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/A.lean @@ -96,7 +96,9 @@ theorem attach_inl_ne_inr {f : W₁.Flag} {v : W₂.Vertex} : change (W₁.attach f).map Sum.inl Sum.inl ≠ Sum.inl (Sum.inr v) rcases W₁.attach f with w | ℓ <;> simp -private theorem attach_inl_vertex_iff {g : W₁.Flag} : +/-- 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 @@ -108,7 +110,9 @@ private theorem attach_inl_vertex_iff {g : W₁.Flag} : · rintro ⟨w, hw⟩ exact ⟨Sum.inl w, attach_inl_eq_inl.mpr hw⟩ -private theorem attach_inr_vertex_iff {g : W₂.Flag} : +/-- 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 @@ -457,33 +461,37 @@ variable {α β : Type} {W₁ : Fragment α} {W₂ : Fragment β} /-! ### Restriction to the components -/ /-- Restrict a union matching to a left flag, fixing it if the image lies on the right. -/ -noncomputable def factorLeftDescend (κ : F.RelTransitionSystem) +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 factorRightDescend (κ : F.RelTransitionSystem) +noncomputable def rightDescend (κ : F.RelTransitionSystem) (g : W₂.Flag) : W₂.Flag := Sum.elim (fun _ => g) id (κ.match_ (Sum.inr g)) -private theorem leftDescend_spec (κ : F.RelTransitionSystem) +/-- 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 (factorLeftDescend κ g) := by + κ.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 factorLeftDescend + · unfold leftDescend rw [hm] rfl · rw [hm] at hvert exact absurd hvert attach_inr_ne_inl -private theorem rightDescend_spec (κ : F.RelTransitionSystem) +/-- 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 (factorRightDescend κ g) := by + κ.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 @@ -492,20 +500,22 @@ private theorem rightDescend_spec (κ : F.RelTransitionSystem) rcases hm : κ.match_ (Sum.inr g) with g' | g' · rw [hm] at hvert exact absurd hvert attach_inl_ne_inr - · unfold factorRightDescend + · unfold rightDescend rw [hm] rfl -private theorem leftDescend_mem (κ : F.RelTransitionSystem) +/-- The left descent of an internal left flag is again internal. -/ +theorem leftDescend_mem (κ : F.RelTransitionSystem) {g : W₁.Flag} (hg : g ∈ (leftSub F).internalFlags) : - factorLeftDescend κ g ∈ (leftSub F).internalFlags := by + 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 -private theorem rightDescend_mem (κ : F.RelTransitionSystem) +/-- The right descent of an internal right flag is again internal. -/ +theorem rightDescend_mem (κ : F.RelTransitionSystem) {g : W₂.Flag} (hg : g ∈ (rightSub F).internalFlags) : - factorRightDescend κ g ∈ (rightSub F).internalFlags := by + 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 @@ -515,7 +525,7 @@ component: the matching never crosses between components, so it restricts. -/ noncomputable def leftRel (κ : F.RelTransitionSystem) : (leftSub F).RelTransitionSystem where - match_ := factorLeftDescend κ + match_ := leftDescend κ match_invol g hg := by have h := κ.match_invol _ (inl_mem_internal.mpr hg) rw [leftDescend_spec κ hg, @@ -535,7 +545,7 @@ noncomputable def leftRel (κ : F.RelTransitionSystem) : /-- The restriction to the right component. -/ noncomputable def rightRel (κ : F.RelTransitionSystem) : (rightSub F).RelTransitionSystem where - match_ := factorRightDescend κ + match_ := rightDescend κ match_invol g hg := by have h := κ.match_invol _ (inr_mem_internal.mpr hg) rw [rightDescend_spec κ hg, @@ -651,7 +661,9 @@ theorem iterWalk_prodRel_inr (κ₁ : (leftSub F).RelTransitionSystem) iterWalk_succ κ₂ g n] rfl -private theorem inl_mem_periodic {κ₁ : (leftSub F).RelTransitionSystem} +/-- 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 ↔ @@ -679,7 +691,9 @@ private theorem inl_mem_periodic {κ₁ : (leftSub F).RelTransitionSystem} exact inl_mem_internal.mpr (hcont j hj) · rw [iterWalk_prodRel_inl κ₁ κ₂ g n, hper] -private theorem inr_mem_periodic {κ₁ : (leftSub F).RelTransitionSystem} +/-- 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 ↔ @@ -707,7 +721,9 @@ private theorem inr_mem_periodic {κ₁ : (leftSub F).RelTransitionSystem} exact inr_mem_internal.mpr (hcont j hj) · rw [iterWalk_prodRel_inr κ₁ κ₂ g n, hper] -private noncomputable def periodicSumEquiv +/-- 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 // @@ -728,7 +744,9 @@ private noncomputable def periodicSumEquiv right_inv x := by rcases x with ⟨g, h⟩ | ⟨g, h⟩ <;> rfl -private theorem walkPermPeriodic_prodRel (κ₁ : (leftSub F).RelTransitionSystem) +/-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean index 0a1cdfa324..0f53be71ec 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean @@ -28,29 +28,39 @@ open EdgeSubset variable {α β : Type} {W₁ : Fragment α} {W₂ : Fragment β} {F : EdgeSubset (W₁.disjUnion W₂)} -private theorem notmem_left {g : W₁.Flag} +/-- 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) -private theorem notmem_left' {g : W₁.Flag} +/-- 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) -private theorem notmem_right {g : W₂.Flag} +/-- 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) -private theorem notmem_right' {g : W₂.Flag} +/-- 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 -/ -private noncomputable def joinEvenVal {k : ℕ} +/-- 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 := @@ -58,21 +68,25 @@ private noncomputable def joinEvenVal {k : ℕ} | ⟨Sum.inl g, hg⟩ => ψ₁.val ⟨g, notmem_left hg⟩ | ⟨Sum.inr g, hg⟩ => ψ₂.val ⟨g, notmem_right hg⟩ -private theorem joinEvenVal_inl {k : ℕ} +/-- 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 -private theorem joinEvenVal_inr {k : ℕ} +/-- 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 -private noncomputable def joinEven {k : ℕ} +/-- 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 @@ -93,7 +107,9 @@ private noncomputable def joinEven {k : ℕ} (ψ₂.prop ⟨g, hgR⟩)).trans (joinEvenVal_inr ψ₁ ψ₂ g hf hgR).symm⟩ -private noncomputable def joinEvenEquiv +/-- 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 @@ -116,7 +132,9 @@ private noncomputable def joinEvenEquiv /-! ### Joining core odd colourings -/ -private noncomputable def joinCoreVal {ℓ : ℕ} +/-- 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 * ℓ) := @@ -124,21 +142,25 @@ private noncomputable def joinCoreVal {ℓ : ℕ} | ⟨Sum.inl g, hg⟩ => φ₁.val ⟨g, inl_mem_core.mp hg⟩ | ⟨Sum.inr g, hg⟩ => φ₂.val ⟨g, inr_mem_core.mp hg⟩ -private theorem joinCoreVal_inl {ℓ : ℕ} +/-- 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 -private theorem joinCoreVal_inr {ℓ : ℕ} +/-- 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 -private noncomputable def joinCore {ℓ : ℕ} +/-- 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 ℓ := @@ -160,7 +182,9 @@ private noncomputable def joinCore {ℓ : ℕ} (φ₂.prop ⟨g, hgR⟩)).trans (joinCoreVal_inr φ₁ φ₂ g hf hgR).symm⟩ -private noncomputable def joinCoreEquiv +/-- 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 ℓ) ≃ @@ -184,7 +208,9 @@ private noncomputable def joinCoreEquiv /-! ### Boundary-match transfer -/ -private theorem genEvenBoundaryMatch_join {k ℓ : ℕ} +/-- 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 @@ -224,7 +250,9 @@ private theorem genEvenBoundaryMatch_join {k ℓ : ℕ} (genBoundaryFlag_not_mem_of_even hbnd₂ b c hst)).trans (h₂ b c hst) -private theorem coreOddBoundaryMatch_join {k ℓ : ℕ} +/-- 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 ℓ) : @@ -256,7 +284,9 @@ private theorem coreOddBoundaryMatch_join {k ℓ : ℕ} /-! ### Even colour multisets at component vertices -/ -private noncomputable def leftComplEmb +/-- 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} := @@ -264,7 +294,9 @@ private noncomputable def leftComplEmb fun _g _g' h => Subtype.ext (Sum.inl.inj (congrArg Subtype.val h))⟩ -private noncomputable def rightComplEmb +/-- 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} := @@ -272,7 +304,9 @@ private noncomputable def rightComplEmb fun _g _g' h => Subtype.ext (Sum.inr.inj (congrArg Subtype.val h))⟩ -private theorem evenColours_aux_inl {k : ℕ} +/-- 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}) @@ -300,7 +334,9 @@ private theorem evenColours_aux_inl {k : ℕ} exact Multiset.map_congr rfl fun g hg => joinEvenVal_inl ψ₁ ψ₂ g.val (notmem_left' g.prop) g.prop -private theorem evenColours_aux_inr {k : ℕ} +/-- 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}) @@ -328,7 +364,9 @@ private theorem evenColours_aux_inr {k : ℕ} exact Multiset.map_congr rfl fun g hg => joinEvenVal_inr ψ₁ ψ₂ g.val (notmem_right' g.prop) g.prop -private theorem evenColoursAt_join_inl {k : ℕ} +/-- 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) = @@ -341,7 +379,9 @@ private theorem evenColoursAt_join_inl {k : ℕ} · intro y simp only [Finset.mem_filter, Finset.mem_univ, true_and] -private theorem evenColoursAt_join_inr {k : ℕ} +/-- 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) = @@ -356,7 +396,9 @@ private theorem evenColoursAt_join_inr {k : ℕ} /-! ### In-flag lists at component vertices -/ -private theorem relInFlagsAt_join_perm_inl +/-- 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) : @@ -392,7 +434,9 @@ private theorem relInFlagsAt_join_perm_inl ⟨mem_leftSub_flags.mp h.1, attach_inl_eq_inl.mpr h.2.1, h.2.2⟩) -private theorem relInFlagsAt_join_perm_inr +/-- 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) : @@ -428,7 +472,9 @@ private theorem relInFlagsAt_join_perm_inr ⟨mem_rightSub_flags.mp h.1, attach_inr_eq_inr.mpr h.2.1, h.2.2⟩) -private theorem mem_internal_of_mem_map_inl +/-- 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) : @@ -437,7 +483,9 @@ private theorem mem_internal_of_mem_map_inl exact inl_mem_internal.mpr ((leftSub F).mem_internal_of_mem_relInFlagsAt hgl) -private theorem mem_internal_of_mem_map_inr +/-- 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) : @@ -448,7 +496,8 @@ private theorem mem_internal_of_mem_map_inr /-! ### `pmap` helpers (mirrors `MixedPartition`) -/ -private theorem perm_pmap' {β' γ' : Type*} {p : β' → Prop} +/-- `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 @@ -461,7 +510,9 @@ private theorem perm_pmap' {β' γ' : Type*} {p : β' → Prop} (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₂) -private theorem pmap_flatMap_congr' {β' β₁ β₂ γ' : Type*} +/-- 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) @@ -476,7 +527,9 @@ private theorem pmap_flatMap_congr' {β' β₁ β₂ γ' : Type*} /-! ### Vertex-local core data at component vertices -/ -private theorem coreOddSignFn_join_inl {ℓ : ℕ} +/-- 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 ℓ) @@ -487,7 +540,9 @@ private theorem coreOddSignFn_join_inl {ℓ : ℕ} ⟨Sum.inl g, hg'⟩ = (leftSub F).coreOddSignFn κ₁ φ₁ ⟨g, hg⟩ := rfl -private theorem coreOddSignFn_join_inr {ℓ : ℕ} +/-- 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 ℓ) @@ -498,7 +553,9 @@ private theorem coreOddSignFn_join_inr {ℓ : ℕ} ⟨Sum.inr g, hg'⟩ = (rightSub F).coreOddSignFn κ₂ φ₂ ⟨g, hg⟩ := rfl -private theorem coreOddPairFn_join_inl {ℓ : ℕ} +/-- 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 ℓ) @@ -509,7 +566,9 @@ private theorem coreOddPairFn_join_inl {ℓ : ℕ} ⟨Sum.inl g, hg'⟩ = (leftSub F).coreOddPairFn κ₁ φ₁ ⟨g, hg⟩ := rfl -private theorem coreOddPairFn_join_inr {ℓ : ℕ} +/-- 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 ℓ) @@ -520,7 +579,9 @@ private theorem coreOddPairFn_join_inr {ℓ : ℕ} ⟨Sum.inr g, hg'⟩ = (rightSub F).coreOddPairFn κ₂ φ₂ ⟨g, hg⟩ := rfl -private theorem coreOddSignAt_join_inl {ℓ : ℕ} +/-- 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) @@ -542,7 +603,9 @@ private theorem coreOddSignAt_join_inl {ℓ : ℕ} (fun a ha h₁ h₂ => coreOddSignFn_join_inl φ₁ φ₂ a h₁ h₂)) (List.map_pmap _).symm -private theorem coreOddSignAt_join_inr {ℓ : ℕ} +/-- 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) @@ -564,7 +627,9 @@ private theorem coreOddSignAt_join_inr {ℓ : ℕ} (fun a ha h₁ h₂ => coreOddSignFn_join_inr φ₁ φ₂ a h₁ h₂)) (List.map_pmap _).symm -private theorem evalOdd_coreOddListAt_join_inl {k ℓ : ℕ} +/-- 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} @@ -591,7 +656,9 @@ private theorem evalOdd_coreOddListAt_join_inl {k ℓ : ℕ} exact pmap_flatMap_congr' _ _ _ _ _ _ _ (fun a ha h₁ h₂ => coreOddPairFn_join_inl φ₁ φ₂ a h₁ h₂) -private theorem evalOdd_coreOddListAt_join_inr {k ℓ : ℕ} +/-- 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} @@ -620,17 +687,21 @@ private theorem evalOdd_coreOddListAt_join_inr {k ℓ : ℕ} /-! ### The colouring-sum factorization -/ -private theorem joinEvenEquiv_apply {k : ℕ} +/-- The even-colouring equivalence is the join. -/ +theorem joinEvenEquiv_apply {k : ℕ} (ψ₁ : (leftSub F).EvenColouring k) (ψ₂ : (rightSub F).EvenColouring k) : joinEvenEquiv F k (ψ₁, ψ₂) = joinEven ψ₁ ψ₂ := rfl -private theorem joinCoreEquiv_apply {ℓ : ℕ} +/-- The core-colouring equivalence is the join. -/ +theorem joinCoreEquiv_apply {ℓ : ℕ} (φ₁ : (leftSub F).CoreOddColouring ℓ) (φ₂ : (rightSub F).CoreOddColouring ℓ) : joinCoreEquiv F ℓ (φ₁, φ₂) = joinCore φ₁ φ₂ := rfl -private theorem prod_vertex_split +/-- 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)) * From 2a60fd2bc607bcf7058a4698c599ffc70e0be774 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Fri, 25 Sep 2026 22:02:02 +0000 Subject: [PATCH 35/46] Repair scoped crossing statements and equivalence proof arguments --- .../RS/Novel/Skein/CrossingDelta.lean | 10 +++ .../RS/Novel/Skein/DisjUnionFactor/B.lean | 1 + .../RS/Novel/Skein/GlueCrossDelta.lean | 5 ++ .../RS/Novel/Skein/GluePathMatch.lean | 6 ++ .../RS/Novel/Skein/PartialCloseTensor.lean | 5 +- .../RS/Novel/Skein/SnakeClasses.lean | 78 ++++++++++--------- .../RS/Novel/Skein/StateFlipSet.lean | 2 + .../RS/Novel/Skein/TensorInterchange.lean | 5 +- 8 files changed, 70 insertions(+), 42 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CrossingDelta.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CrossingDelta.lean index a09a62c651..449f6b686e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CrossingDelta.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CrossingDelta.lean @@ -48,6 +48,7 @@ theorem chordPairCrossSym_iff [LinearOrder α] (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`. -/ @@ -74,6 +75,7 @@ private theorem sorted_pair_sum [LinearOrder α] · 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. -/ @@ -109,6 +111,7 @@ private theorem side_label_sum [LinearOrder α] 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 @@ -220,6 +223,7 @@ private theorem sum_split_four {β : Type} (S : Finset β) 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 @@ -245,6 +249,7 @@ private theorem chordCross_ite_eq 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} @@ -255,6 +260,7 @@ private theorem chordCross_self_ite 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} @@ -270,6 +276,7 @@ private theorem chordCross_partner_ite 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. -/ @@ -324,6 +331,7 @@ private theorem chordCross_quad_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. -/ @@ -351,6 +359,7 @@ private theorem chordCross_side_sum 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 @@ -522,6 +531,7 @@ private theorem filter_touched_eq {W : Fragment α} {F : EdgeSubset W} 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean index 0f53be71ec..fbd33aa534 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/B.lean @@ -708,6 +708,7 @@ theorem prod_vertex_split ∏ 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCrossDelta.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCrossDelta.lean index 959fde4ab9..54e147e8f3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCrossDelta.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueCrossDelta.lean @@ -68,6 +68,7 @@ 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 α] @@ -144,6 +145,7 @@ private theorem max_ne_of_ne [LinearOrder α] 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 α] @@ -156,6 +158,7 @@ private theorem inside_sorted_sum [LinearOrder α] · 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`. -/ @@ -177,6 +180,7 @@ private theorem cross_parity_raw [LinearOrder α] (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 α] @@ -228,6 +232,7 @@ 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, diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GluePathMatch.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GluePathMatch.lean index 9718131ddf..10b2149037 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GluePathMatch.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GluePathMatch.lean @@ -204,6 +204,7 @@ theorem iterWalk_glueOpen_from ((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 @@ -218,6 +219,7 @@ theorem boundary_mk_of_glueOpen 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} @@ -262,6 +264,7 @@ theorem pathMatch_exit_unique {α' : Type} (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. -/ @@ -359,6 +362,7 @@ private theorem iterWalk_glueOpen_internal 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 @@ -554,6 +558,7 @@ theorem pathMatch_glueOpen_hit_i 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 @@ -755,6 +760,7 @@ theorem pathMatch_glueOpen_hit_j end PathMatchGlue open EdgeSubset Fragment in +open scoped Classical in /-- Participation transports through the open glue at label level. -/ theorem glued_participation_iff diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean index 778d7e3910..f5ace40ef5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PartialCloseTensor.lean @@ -320,7 +320,8 @@ noncomputable def pcTensorQs (s t u v : ℕ) := Fragment.mapPairs (pcTensorPeel s t u v).symm (zClosePairs s t u v) -private theorem pcTensorQs_wf (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) @@ -359,7 +360,7 @@ noncomputable def pcTensorNormal {s t u v : ℕ} let eP := pcTensorPeel s t u v let qsP := pcTensorQs s t u v have wfqsP : Fragment.PairsWF qsP := by - exact pcTensorQs_wf s t u v + 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)) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/SnakeClasses.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/SnakeClasses.lean index 5a46896f88..0776811395 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/SnakeClasses.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/SnakeClasses.lean @@ -73,25 +73,26 @@ noncomputable def snakeFragLEquiv : 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⟩) + (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 @@ -115,25 +116,26 @@ noncomputable def snakeFragREquiv : 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⟩) + (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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/StateFlipSet.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/StateFlipSet.lean index 790443ace4..9e2b8eec47 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/StateFlipSet.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/StateFlipSet.lean @@ -50,6 +50,7 @@ theorem stateOddFlipSet_empty : 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 @@ -68,6 +69,7 @@ theorem stateOddFlip_eq_flipSet {i₁ i₂ : α} : · 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean index 6598ca1b7e..5f4ce0a132 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean @@ -736,8 +736,9 @@ noncomputable def interchangeNormalRight (Fragment.mapPairs_wf e_l _ (inrPairs_wf ips₂ wf₂)) (List.Perm.of_eq - (by exact liftPairs_inlPairs_inrPairs ips₁ ips₂ - wf_lr.append_sep))) + (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 From 7b5cfd2d9c91395e9e820339752e062ca18dfad7 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Fri, 25 Sep 2026 22:15:19 +0000 Subject: [PATCH 36/46] Lay out the final tensor survivor proof argument explicitly --- .../RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean index 5f4ce0a132..1f854699ee 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TensorInterchange.lean @@ -775,8 +775,9 @@ noncomputable def interchangeNormalRight (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))))) + (Equiv.relabelEq _ (by + exact interchange_survivor_relabel_eq _ + (fun x => by cases x <;> rfl))))) /-! ### Final assembly -/ From 8d24bd89858628a0c10334e7f463742913c45550 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Fri, 25 Sep 2026 22:25:58 +0000 Subject: [PATCH 37/46] Repair downstream skein instances and preserve order-comparison interfaces --- .../RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean | 2 +- .../RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean | 2 +- LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean | 1 + .../RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean | 4 ++++ LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.lean | 1 + LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.lean | 1 + LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.lean | 2 ++ LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean | 2 ++ .../RegtsSevenster/RS/Novel/Skein/TransitionExists.lean | 6 +++--- 9 files changed, 16 insertions(+), 5 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean index e7fa070063..78adba74aa 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean @@ -953,7 +953,7 @@ theorem colourMerge_coord_odd {k ℓ : ℕ} (a b : ℕ) else (colourPowerEquiv k ℓ a).oddEquiv x ⟨c.firstHalf, h⟩ * (colourPowerEquiv k ℓ b).evenEquiv w ⟨c.secondHalf, - c.secondHalf_isEven_of_not hc h⟩ := + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean index 030ce81c6d..cef423ce08 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean @@ -503,7 +503,7 @@ noncomputable instance matEmbeddingBraided [Category.{v} C] [Preadditive C] [MonoidalCategory C] [MonoidalPreadditive C] [BraidedCategory C] : Functor.Braided (Mat_.embedding C) where - braided := matEmb_braided + braided := by exact matEmb_braided end Braided diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean index 08b8c358e8..29fc259d5c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/CutMatching.lean @@ -77,6 +77,7 @@ theorem decide_lt_flip [LinearOrder α] · 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean index 0014a7369b..68bc455613 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean @@ -38,6 +38,7 @@ 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₂)} @@ -54,6 +55,7 @@ theorem inl_mem_boundary 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₂)} @@ -74,6 +76,7 @@ theorem inr_mem_boundary -- The proof introduces the lexicographic order on the sum, which -- needs both component orders even though the statement does not. +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 @@ -110,6 +113,7 @@ theorem pathMatch_prodRel_inl -- The proof introduces the lexicographic order on the sum, which -- needs both component orders even though the statement does not. +open scoped Classical in /-- And likewise on the right. -/ theorem pathMatch_prodRel_inr {W₁ : Fragment α} {W₂ : Fragment β} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.lean index 58b5a1607e..460a2ddfde 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeSum.lean @@ -38,6 +38,7 @@ namespace EdgeSubset variable {α : Type} +open scoped Classical in /-- **RS21's colouring sum** over the colourings of the whole subset. -/ noncomputable def edgeSum {W : Fragment α} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.lean index b3ce8a4312..053b8859e0 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignProduct.lean @@ -26,6 +26,7 @@ namespace RS variable {α : Type} {ℓ : ℕ} +open scoped Classical in /-- The colour relabel of one flip. -/ noncomputable def flipColours (f : α → Fin (2 * ℓ)) (p : α × α) : α → Fin (2 * ℓ) := diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.lean index 240b7876f1..b18504ee93 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FourLabelParity.lean @@ -40,6 +40,7 @@ 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 @@ -81,6 +82,7 @@ theorem fourLabel_parity_sep [LinearOrder α] 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean index 0fedeffe66..a4f50e7dd4 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean @@ -37,6 +37,7 @@ 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 α := @@ -91,6 +92,7 @@ theorem symmU_assoc (E₁ E₂ E₃ : Finset α) : 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} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean index 55a8643e69..050fad2cde 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean @@ -386,7 +386,7 @@ section Orientation variable {α : Type} {W : Fragment α} {F : EdgeSubset W} /-- In a linear order, a ≠ b implies decide(a < b) = !decide(b < a). -/ -theorem decide_lt_flip {γ : Type} [LinearOrder γ] +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 @@ -466,7 +466,7 @@ noncomputable def EdgeSubset.TransitionSystem.buildOrientation 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 decide_lt_flip (Ne.symm (orbitMin_pairing_ne ⟨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 @@ -479,7 +479,7 @@ noncomputable def EdgeSubset.TransitionSystem.buildOrientation {f : W.Flag // f ∈ F.flags}) = F.pairingPerm ⟨g, hg⟩ := Subtype.ext (by simp) rw [hσσ, hσ_eq] - exact decide_lt_flip (Ne.symm (orbitMin_pairing_ne ⟨g, hg⟩)) + exact transition_decide_lt_flip (Ne.symm (orbitMin_pairing_ne ⟨g, hg⟩)) exact ⟨isOut, hmatch_flip, hpairing_flip⟩ /-! ### The main theorem -/ From 8506caa80f1215829c61322768b0153ee3fc927b Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Sat, 26 Sep 2026 03:12:11 +0000 Subject: [PATCH 38/46] Repair remaining tensor and coordinate module interfaces --- .../RS/Novel/Coordinates/CanonPerm.lean | 6 +++--- .../RS/Novel/Coordinates/RegroupSign.lean | 12 +++++++----- .../RS/Novel/Skein/DisjUnionFactor/C.lean | 6 ------ .../RegtsSevenster/RS/Novel/Skein/FlipSignForm.lean | 2 ++ .../RegtsSevenster/RS/Novel/Skein/LedgerSets.lean | 2 ++ LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean | 2 ++ 6 files changed, 16 insertions(+), 14 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean index ad0554be54..ebc9d24e97 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean @@ -186,7 +186,7 @@ private theorem vr_comp_canon_mono (μm : Multiset (Fin k)) (F : Finset (Fin (2 simp only [colourValueRank] have hpw := Multiset.pairwise_sort μm (· ≤ ·) have hlen := show (μm.sort (· ≤ ·)).length = μm.card from by simp - exact hpw.sortedLE (Fin.mk_le_mk.mpr (by omega) : + 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 _) @@ -202,7 +202,7 @@ private theorem vr_comp_canon_mono (μm : Multiset (Fin k)) (F : Finset (Fin (2 show k + _ ≤ k + _ have hpw := Finset.pairwise_sort F (· ≤ ·) have hlen := show (F.sort (· ≤ ·)).length = F.card from by simp - have hle := hpw.sortedLE (Fin.mk_le_mk.mpr (by omega) : + 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 @@ -654,7 +654,7 @@ private theorem canonSortPerm_sign {d : ℕ} (c : MixedColouring k ℓ d) 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 (show (⟨a.val, _⟩ : Fin (F.sort (· ≤ ·)).length) < ⟨b.val, _⟩ + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean index 76905a71b7..c1479a9e55 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean @@ -694,7 +694,7 @@ theorem sign_listIndexPerm_oriented_matched (W : ClosedFragment) (F : EdgeSubset (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)) = + (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 @@ -935,10 +935,12 @@ 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) (globalPairList_nodup' W F o) - (fun x => ⟨fun _ => mem_globalPairList' W F o x, - fun _ => mem_matchedPairList' W F o x⟩) - (len_matched_eq_global 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean index 68bc455613..9d228d19fc 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionFactor/C.lean @@ -74,8 +74,6 @@ theorem inr_mem_boundary /-! ### The path match of the product system is componentwise -/ --- The proof introduces the lexicographic order on the sum, which --- needs both component orders even though the statement does not. open scoped Classical in /-- A left boundary flag's chain stays left, so the product system's path matching is the left component's. -/ @@ -89,7 +87,6 @@ theorem pathMatch_prodRel_inl (hb' : g ∈ (leftSub F).boundaryFlags) : (prodRel (F := F) κ₁ κ₂).pathMatch (Sum.inl g) hb = Sum.inl (κ₁.pathMatch g hb') := by - let := sumLexLinearOrder α β obtain ⟨k, -, hcont, hpm⟩ := pathMatch_chain_length κ₁ hb' have hterm : W₁.pairing (iterWalk κ₁ g k) ∈ (leftSub F).boundaryFlags := by @@ -111,8 +108,6 @@ theorem pathMatch_prodRel_inl hcontU htermU).trans ?_ rw [iterWalk_prodRel_inl κ₁ κ₂ g k, pairing_inl, hpm] --- The proof introduces the lexicographic order on the sum, which --- needs both component orders even though the statement does not. open scoped Classical in /-- And likewise on the right. -/ theorem pathMatch_prodRel_inr @@ -125,7 +120,6 @@ theorem pathMatch_prodRel_inr (hb' : g ∈ (rightSub F).boundaryFlags) : (prodRel (F := F) κ₁ κ₂).pathMatch (Sum.inr g) hb = Sum.inr (κ₂.pathMatch g hb') := by - let := sumLexLinearOrder α β obtain ⟨k, -, hcont, hpm⟩ := pathMatch_chain_length κ₂ hb' have hterm : W₂.pairing (iterWalk κ₂ g k) ∈ (rightSub F).boundaryFlags := by diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignForm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignForm.lean index 1434e5025f..63cbb7da7d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignForm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FlipSignForm.lean @@ -100,6 +100,7 @@ private theorem step_algebra (x : ℤ) (n : ℕ) : 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. -/ @@ -174,6 +175,7 @@ theorem flipSignProd_formula (f : α → Fin (2 * ℓ)) 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 * ℓ)) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean index a4f50e7dd4..eb321acb50 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerSets.lean @@ -48,6 +48,7 @@ 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] @@ -99,6 +100,7 @@ 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] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean index 672fa28c84..b623330ed4 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/RSTensor.lean @@ -44,6 +44,7 @@ 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 ℓ : ℕ} @@ -63,6 +64,7 @@ noncomputable def tPrime [LinearOrder α] [Fintype α] {W : Fragment α} 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`. -/ From 44adb234532519c287d198c5b9d3fe3e2ee767be Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Sat, 26 Sep 2026 03:43:54 +0000 Subject: [PATCH 39/46] Supply local classical instances for glued colouring sums --- LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean | 1 + LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean | 5 +++-- LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean | 1 + 3 files changed, 5 insertions(+), 2 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean index 5a2d68e01f..9b58591b58 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourGlue.lean @@ -804,6 +804,7 @@ theorem genEvenBoundaryMatch_hit_iff {k ℓ : ℕ} 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 ℓ : ℕ} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean index a3ecd68950..74e72784aa 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/DisjUnionProduct.lean @@ -78,8 +78,9 @@ 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 := - Finset.mem_filter + ∃ v : W.Vertex, W.attach f = Sum.inl v := by + classical + exact Finset.mem_filter /-! ## The canonical-value migration diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean index 78818e8f92..d34cd7d454 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/GlueChord.lean @@ -544,6 +544,7 @@ theorem chordInv_closed_pair (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 From ec6038b36506f2de524631bd36b4f1addfb1df7e Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Sat, 26 Sep 2026 04:54:43 +0000 Subject: [PATCH 40/46] refactor(RegtsSevenster): finish tactic and proof-budget commentary cleanup --- .../RS/Classical/Deligne/ChainBGr.lean | 12 ++++++------ .../RS/Classical/Deligne/IndTensorExact.lean | 8 ++++---- .../RegtsSevenster/RS/Classical/Deligne/ModIns.lean | 8 ++++---- .../RS/Classical/Deligne/ModTensor.lean | 6 +++--- .../RS/Classical/Deligne/SplitAssemble.lean | 4 ++-- .../RS/Classical/Deligne/SplitMonHom.lean | 2 +- .../RS/Classical/Deligne/SplitPairDef.lean | 2 +- .../RS/Classical/Deligne/SuperRealize.lean | 2 +- .../RS/Classical/Deligne/SuperVectSchur.lean | 2 +- .../RS/Classical/SchurTheory/JTPad.lean | 2 +- .../RS/Classical/SchurTheory/OrbitBridge.lean | 2 +- .../RS/Classical/SchurTheory/SignedTensor.lean | 2 +- .../RS/Classical/SchurTheory/SimpleEmbed.lean | 2 +- .../RS/Classical/Super/ColourConjStep.lean | 2 +- .../RS/Classical/Super/ColourConjTop.lean | 6 +++--- .../RS/Classical/Super/ColourExtendSwap.lean | 4 ++-- .../RS/Classical/Super/ColourMerge.lean | 6 +++--- .../RS/Classical/Super/ColourMergeOdd.lean | 6 +++--- .../RS/Classical/SymFun/RecurrenceFromVanishing.lean | 2 +- .../RS/Classical/SymFun/ZetaRational.lean | 2 +- LeanPool/RegtsSevenster/RS/Common/ListPairs.lean | 2 +- LeanPool/RegtsSevenster/RS/Definitions.lean | 4 ++-- .../RS/Novel/Coordinates/BasisSplit.lean | 2 +- .../RS/Novel/Coordinates/BetaData.lean | 2 +- .../RS/Novel/Coordinates/BetaDiagForm.lean | 2 +- .../RS/Novel/Coordinates/BlockCanon.lean | 2 +- .../RS/Novel/Coordinates/BlockData.lean | 2 +- .../RS/Novel/Coordinates/BlockOddList.lean | 2 +- .../RS/Novel/Coordinates/CanonPerm.lean | 10 +++++----- .../RS/Novel/Coordinates/CapClosed.lean | 2 +- .../RS/Novel/Coordinates/CapPeelSplit.lean | 4 ++-- .../RS/Novel/Coordinates/CapSplit.lean | 2 +- .../RS/Novel/Coordinates/CircleModel.lean | 2 +- .../RS/Novel/Coordinates/CoreParity.lean | 2 +- .../RegtsSevenster/RS/Novel/Coordinates/EvLeaf.lean | 2 +- .../RS/Novel/Coordinates/FibreParam.lean | 2 +- .../RS/Novel/Coordinates/MasterSum.lean | 2 +- .../RS/Novel/Coordinates/ModelCoord.lean | 2 +- .../RS/Novel/Coordinates/ModelStarVec.lean | 2 +- .../RegtsSevenster/RS/Novel/Coordinates/NFDef.lean | 4 ++-- .../RegtsSevenster/RS/Novel/Coordinates/NFValue.lean | 2 +- .../RegtsSevenster/RS/Novel/Coordinates/OddPair.lean | 2 +- .../RS/Novel/Coordinates/OddSignProd.lean | 2 +- .../RS/Novel/Coordinates/OmegaCotensor.lean | 2 +- .../RS/Novel/Coordinates/OmegaTensor.lean | 2 +- .../RS/Novel/Coordinates/OneBasis.lean | 2 +- .../RS/Novel/Coordinates/ParameterModel.lean | 2 +- .../RS/Novel/Coordinates/PowMerge.lean | 2 +- .../RS/Novel/Coordinates/RegroupSign.lean | 6 +++--- .../RS/Novel/Coordinates/ReindexBij.lean | 2 +- .../RS/Novel/Coordinates/ReindexHeart.lean | 2 +- .../RS/Novel/Coordinates/ReindexVanish.lean | 2 +- .../RS/Novel/Coordinates/SkeinPowBraid.lean | 2 +- .../RS/Novel/Coordinates/StarPerm.lean | 4 ++-- .../RS/Novel/Coordinates/StrandTransport.lean | 2 +- .../RS/Novel/Coordinates/TopBraidMerge.lean | 2 +- .../RS/Novel/Coordinates/VertexSign.lean | 2 +- .../RS/Novel/Coordinates/VertexValue.lean | 2 +- .../RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean | 2 +- .../RS/Novel/Envelope/BlockFactor.lean | 6 +++--- .../RS/Novel/Envelope/EnvGenerator.lean | 2 +- .../RS/Novel/Envelope/KaroubiMonoidal.lean | 4 ++-- .../RegtsSevenster/RS/Novel/Envelope/MatBraided.lean | 8 ++++---- .../RS/Novel/Envelope/MatEmbMonoidal.lean | 6 +++--- .../RS/Novel/Envelope/MatMonoidal.lean | 2 +- .../RegtsSevenster/RS/Novel/Envelope/MatRigid.lean | 2 +- .../RegtsSevenster/RS/Novel/Extraction/StdRigid.lean | 8 ++++---- .../RegtsSevenster/RS/Novel/Skein/BundleClose.lean | 2 +- .../RegtsSevenster/RS/Novel/Skein/ColourPadding.lean | 2 +- .../RS/Novel/Skein/ConverseFamily.lean | 2 +- .../RegtsSevenster/RS/Novel/Skein/ConverseLift.lean | 2 +- .../RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean | 12 ++++++------ .../RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean | 4 ++-- .../RS/Novel/Skein/InterfaceShift.lean | 2 +- .../RS/Novel/Skein/LedgerRecursion.lean | 4 ++-- .../RS/Novel/Skein/TransitionExists.lean | 8 ++++---- 76 files changed, 128 insertions(+), 128 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean index e44cfdd595..3afe689d64 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ChainBGr.lean @@ -406,7 +406,7 @@ end GradedMul section ZeroDegreeMul --- Raised budget: the graded chain's structure maps unfold +-- 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 @@ -428,7 +428,7 @@ theorem chainBdegι_chainBdegZeroIso_hom (chainDelta A M M' d) k := ι_chainColimitMapIso_hom _ _ _ _ _ k --- Raised budget: the graded chain's structure maps unfold +-- The graded chain's structure maps unfold -- through the colimit cocone and the duality datum together. end ZeroDegreeMul @@ -806,7 +806,7 @@ theorem chainBdegShiftIso_succ chainBdegSuccIso A M M' d (p₀ + n) (q₀ + n) ≪≫ chainBdegShiftIso A M M' d p₀ q₀ n := rfl --- Raised budget: the graded chain's structure maps unfold +-- 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 @@ -837,7 +837,7 @@ theorem chainBdegι_chainBdegSuccIso_hom (fun k => chainDelta2 A M M' d (p₀ + k) (q₀ + k)) k)) ?_ rfl --- Raised budget: the graded chain's structure maps unfold +-- 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 @@ -1381,7 +1381,7 @@ end CarrierAssoc section UnitLaws --- Raised budget: the graded chain's structure maps unfold +-- 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 @@ -1436,7 +1436,7 @@ theorem ι_tensorHom_chainBGrCompMul_zero_left ((0 : ℤ).toNat + b.toNat - (0 + b).toNat)) := ι_tensorHom_chainBGrCompMul A M M' d 0 b 0 j --- Raised budget: the graded chain's structure maps unfold +-- 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, diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean index 45a380fc5a..6ced52053a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/IndTensorExact.lean @@ -873,7 +873,7 @@ lemma isIso_of_coprod_eq_whiskerRight_indOf rw [key] infer_instance --- Raised budget: the biproduct-preservation instances for +-- 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`. @@ -905,7 +905,7 @@ lemma isIso_coprodComparison_tensorLeft_indOf₀ (coprodComparison_inl (tensorLeft (indOf.obj a))) (coprodComparison_inr (tensorLeft (indOf.obj a))) --- Raised budget: the mirror of the left version, with the same +-- 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₀ @@ -1211,7 +1211,7 @@ lemma isZero_colimit_of_isZero rw [Category.comp_id, comp_zero] exact (h j).eq_of_src _ _ --- Raised budget: three isomorphisms of ind-objects are chained +-- 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`. @@ -1246,7 +1246,7 @@ lemma isZero_tensor_left_ind exact IsZero.of_iso (isZero_colimit_of_isZero (D ⋙ tensorRight (indOf.obj 0)) hpt) (e₁ ≪≫ e₂ ≪≫ e₃) --- Raised budget: the mirror of the left version, with the same +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean index b4c925a0da..60f3bfa467 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean @@ -53,22 +53,22 @@ theorem append_pair_slot_cases rcases post.eq_nil_or_concat with h | ⟨post', q, rfl⟩ · subst h have := congrArg List.reverse hd - simp? at this + simp 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? at this + simp 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? at h4 + simp at h4 rw [h4] · have := congrArg List.reverse hd - simp? at this + simp at this obtain ⟨h1, h2, h3⟩ := this refine Or.inl ⟨post'', ⟨by rw [show (post''.concat q').concat q = diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean index 8a29df73c3..dd57102015 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean @@ -243,7 +243,7 @@ lemma actLeft_actRight [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (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? [actRight, actLeft_actLeft] + simp [actRight, actLeft_actLeft] rw [← comp_whiskerRight_assoc, IsCommMonObj.mul_comm] /-- For a commutative monoid, the braided right action is @@ -254,7 +254,7 @@ lemma actRight_actRight [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (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? [actRight, actLeft_actLeft] + simp [actRight, actLeft_actLeft] rw [← comp_whiskerRight_assoc, IsCommMonObj.mul_comm] end RightAction @@ -943,7 +943,7 @@ lemma modTensorAct_map [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] 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? + simp rw [← tensorHom_id (actLeft A M.X) N.X, ← tensorHom_id (actLeft A M'.X) N'.X, tensorHom_comp_tensorHom, tensorHom_comp_tensorHom] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean index 6d8bd3fb9b..acb2330acb 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitAssemble.lean @@ -109,7 +109,7 @@ theorem splitOfBase_unit section Linear --- Raised budget: linearity of the insertion unfolds the module +-- 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 @@ -270,7 +270,7 @@ theorem splitIns_linear refine Eq.trans (whisker_eq _ habs) ?_ exact Category.assoc _ _ _ --- Raised budget: linearity of the insertion unfolds the module +-- 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean index 6c5e08b413..ee58b86e35 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitMonHom.lean @@ -112,7 +112,7 @@ theorem mul_chainBaseStage refine Eq.trans (Category.assoc _ _ _) ?_ exact whisker_eq _ (by rw [chainBaseStage]; rfl) --- Raised budget: the multiplication of the split algebra unfolds +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitPairDef.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitPairDef.lean index b8b40a129f..c62f9ce320 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitPairDef.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SplitPairDef.lean @@ -56,7 +56,7 @@ private theorem compι_ι_degCast (chainBGrCompι_eqToHom A M M' d h k) _) ?_ exact Category.assoc _ _ _ --- Raised budget: the relative tensor projection unfolds against +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean index f1a4f300d3..c8883defb9 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean @@ -692,7 +692,7 @@ theorem unitHomMul_assoc R ◁ R ◁ c ≫ R ◁ μ[R] ≫ μ[R] := by rw [rightUnitor_inv_naturality_assoc, ← whisker_exchange_assoc, MonObj.mul_assoc, associator_naturality_right_assoc] - simp? [unitHomMul, tensorHom_def] + simp [unitHomMul, tensorHom_def] rw [← unitors_equal] simp only [Iso.inv_hom_id_assoc] rw [key] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean index 90f3046cb0..03600d4c6a 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperVectSchur.lean @@ -558,7 +558,7 @@ private theorem trace_comp_comm_monoid {M N : Type*} let : AddCommGroup N := Module.addCommMonoidToAddCommGroup ℂ exact LinearMap.trace_comp_comm' f g --- Raised budget: the supertrace is conjugated through the +-- 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) : diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean index c5c216d851..47adfd0331 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean @@ -260,7 +260,7 @@ theorem colourChar_extend_zero {n N k : ℕ} (hNk : N ≤ k) constructor · intro h have := congrArg Fin.val h - simp? [Fin.val_castLE] at this + simp [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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/OrbitBridge.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/OrbitBridge.lean index b3bc086152..14e92e7658 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/OrbitBridge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/OrbitBridge.lean @@ -152,7 +152,7 @@ end Helpers /-! ## Main theorem -/ --- Raised budget: the orbit cardinality is computed by rewriting a +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean index 116f6dbee9..f8a43c1df4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean @@ -70,7 +70,7 @@ theorem sign_mul_cycleProd_const {n : ℕ} (m : ℕ) set K := c + (n - s) have hsn : s ≤ n := by have := Equiv.Perm.sum_cycleType_le π - simp? [Fintype.card_fin] at this + simp [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 := diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean index 27b0890e4e..1d06280376 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean @@ -48,7 +48,7 @@ theorem exists_simple_submodule_linearEquiv [Group G] [Finite G] have h1 : φ 1 ∈ range φ := mem_range_self φ 1 have h1bot := h h1 rw [Submodule.mem_bot] at h1bot - simp? [φ, toSpanSingleton, smulRight] at h1bot + simp [φ, toSpanSingleton, smulRight] at h1bot exact hm h1bot rcases hM.eq_bot_or_eq_top (range φ) with h | h · exact absurd h hne diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjStep.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjStep.lean index 83d11c5af7..d614b0d4e1 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjStep.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjStep.lean @@ -46,7 +46,7 @@ private lemma congr_refl_map_id {M₁ M₂ N : Type*} TensorProduct.congr_tmul] | add x y hx hy => simp only [map_add, hx, hy] --- Raised budget: the colouring equivalence at arity `n+1` +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean index b3cb6ec419..58d0ff43c4 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourConjTop.lean @@ -580,7 +580,7 @@ private theorem colourFun_neg_apply {n : ℕ} /-! ### The even-component coordinate identity -/ --- Raised budget: one coordinate of the Koszul braiding at two +-- 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 @@ -1791,7 +1791,7 @@ private theorem adjSign_secondHalf (n : ℕ) /-! ### The general even coordinate identity -/ --- Raised budget: the two-strand coordinate transported over `n` +-- 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 : ℕ) @@ -2250,7 +2250,7 @@ private theorem braidN_coord_odd (n : ℕ) exact hPadd _ _ hs ht | tmul p q => exact hblock2 p q --- Raised budget: assembling the two coordinate formulas into an +-- 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.** -/ diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourExtendSwap.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourExtendSwap.lean index 862e6d0ab0..f4c5f8be75 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourExtendSwap.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourExtendSwap.lean @@ -74,7 +74,7 @@ private theorem funTensorFun_map_id {ι κ : Type} [Fintype ι] /-! ### Computation lemmas for `colourPowerStep` applied at a point -/ --- Raised budget: the tensor step equivalence is applied to a +-- 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) @@ -339,7 +339,7 @@ private theorem oddSplitEquiv_swap_inr {n i : ℕ} (h : i + 2 ≤ n + 1) /-! ### Main theorem -/ --- Raised budget: both components unfold the step equivalence and +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMerge.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMerge.lean index 8398a1ec20..b9e25b5d0b 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMerge.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMerge.lean @@ -392,7 +392,7 @@ private theorem assoc_inv_odd_oe_tmul {k ℓ a b : ℕ} /-! ### Full chain reduction on pure tensor generators -/ --- Raised budget: the merge, the colouring equivalence at arity +-- 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 @@ -740,7 +740,7 @@ theorem rhs_odd_oe {k ℓ b : ℕ} /-! ### The merge coordinate product rule -/ --- Raised budget: the even and odd coordinate formulas are proved +-- 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 : ℕ) @@ -1172,7 +1172,7 @@ private theorem colourMerge_pair {k ℓ : ℕ} (a : ℕ) · exact colourMerge_pair_even_step a v b ih_even ih_odd · exact colourMerge_pair_odd_step a v b ih_even ih_odd --- Raised budget: specializing the mutual induction re-elaborates +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean index 78adba74aa..adf3c6aa33 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Super/ColourMergeOdd.lean @@ -170,7 +170,7 @@ private theorem assoc_inv_even_oe_oe_tmul {k ℓ a b : ℕ} /-! ### Full chain reduction on pure tensor generators (odd input) -/ --- Raised budget: as in `ColourMerge`, the merge and the colouring +-- 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 @@ -827,7 +827,7 @@ private theorem colourMerge_pair_odd_even_step {k ℓ : ℕ} (a : ℕ) 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) --- Raised budget: specializing the mutual induction re-elaborates +-- Specializing the mutual induction re-elaborates -- the paired statement. private theorem colourMerge_pair_odd {k ℓ : ℕ} (a : ℕ) @@ -988,7 +988,7 @@ theorem single_val_ne {n : ℕ} {c : MixedColouring k ℓ n // p c} → ℂ) y = 0 := Pi.single_eq_of_ne (fun he => h (congrArg Subtype.val he)) 1 --- Raised budget: the graded single-basis-vector coordinate is +-- The graded single-basis-vector coordinate is -- computed through the colouring equivalence. /-- Subtype coordinate singles evaluate by values: same. -/ theorem single_val_same {n : ℕ} diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/RecurrenceFromVanishing.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RecurrenceFromVanishing.lean index 95e2c620a2..00d02a9294 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/RecurrenceFromVanishing.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/RecurrenceFromVanishing.lean @@ -206,7 +206,7 @@ private lemma det_vanishing_of_all_ge {t : ℕ → ℂ} {a b : ℕ} /-! ### Stage 3: extracting the recurrence -/ --- Raised budget: one elaboration of the span/annihilator assembly +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaRational.lean b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaRational.lean index cb0f30ec96..fd34605a23 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaRational.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SymFun/ZetaRational.lean @@ -27,7 +27,7 @@ open scoped Polynomial PowerSeries /-! ### Normalising both constant terms to 1 -/ --- Raised budget: the rational form is assembled from the +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Common/ListPairs.lean b/LeanPool/RegtsSevenster/RS/Common/ListPairs.lean index d5533b32de..61670ed0c1 100644 --- a/LeanPool/RegtsSevenster/RS/Common/ListPairs.lean +++ b/LeanPool/RegtsSevenster/RS/Common/ListPairs.lean @@ -26,7 +26,7 @@ theorem len_flatMap_pair {α β : Type*} (L : List α) (f g : α → β) : | nil => simp | cons a t ih => simp [List.flatMap_cons, ih]; omega --- Raised budget: the index arithmetic under the flat-map is +-- 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*} diff --git a/LeanPool/RegtsSevenster/RS/Definitions.lean b/LeanPool/RegtsSevenster/RS/Definitions.lean index a70fd61918..d0e9fc2db6 100644 --- a/LeanPool/RegtsSevenster/RS/Definitions.lean +++ b/LeanPool/RegtsSevenster/RS/Definitions.lean @@ -182,7 +182,7 @@ def disjUnion (W₁ : Fragment α) (W₂ : Fragment β) : | inl ℓ₁ => cases f with | inl g => - rcases ha : W₁.attach g with v | ℓ' <;> simp? [ha] at h + rcases ha : W₁.attach g with v | ℓ' <;> simp [ha] at h subst h simp [W₁.eq_boundaryFlag ℓ' g ha] | inr g => @@ -192,7 +192,7 @@ def disjUnion (W₁ : Fragment α) (W₂ : Fragment β) : | inl g => rcases ha : W₁.attach g with v | ℓ' <;> simp [ha] at h | inr g => - rcases ha : W₂.attach g with v | ℓ' <;> simp? [ha] at h + rcases ha : W₂.attach g with v | ℓ' <;> simp [ha] at h subst h simp [W₂.eq_boundaryFlag ℓ' g ha] circles := W₁.circles + W₂.circles diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisSplit.lean index 88465a4720..4daa5052a6 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BasisSplit.lean @@ -46,7 +46,7 @@ theorem MixedColouring.ext_halves {a b : ℕ} funext (fun i => Fin.addCases (fun j => congrFun h1 j) (fun j => congrFun h2 j) i) --- Raised budget: the basis vector is expanded through the merge on +-- 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.** -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaData.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaData.lean index 6e2acc9616..ed7ffab7ac 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaData.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaData.lean @@ -120,7 +120,7 @@ theorem colouringOf_natAdd (W : ClosedFragment) (F : EdgeSubset W) exact Eq.trans (congrArg ψ.val harg) (ψ.property ⟨_, h⟩) open Classical in --- Raised budget: the diagonal pairing is expanded position by +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiagForm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiagForm.lean index 24a160d279..6952ac857e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiagForm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BetaDiagForm.lean @@ -416,7 +416,7 @@ private theorem sign_eq (m : ℕ) /-! ### The main theorem -/ --- Raised budget: the induction on the arity carries the whole +-- 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)`. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockCanon.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockCanon.lean index 54669d7e42..125c000b88 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockCanon.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockCanon.lean @@ -65,7 +65,7 @@ private theorem filterMap_eq_map_of_some {γ δ : Type*} (some (g' a))).getD 0) = {g' a} from rfl] rw [Multiset.singleton_add] --- Raised budget: the list is rewritten through `filterMap` on the +-- 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**, diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockData.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockData.lean index 7c3ac34c06..79066f2afc 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockData.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockData.lean @@ -151,7 +151,7 @@ theorem blockSlot_not_mem {W : ClosedFragment} blockFlag W v j.val ∉ F.flags := (Finset.mem_filter.mp j.prop).2 --- Raised budget: a filter over flags is matched against a filter +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockOddList.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockOddList.lean index d19c554208..76fd80ce62 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockOddList.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/BlockOddList.lean @@ -25,7 +25,7 @@ open Finset variable {k ℓ : ℕ} --- Raised budget: the block's odd list is matched with the sorted +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean index ebc9d24e97..2183961f09 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean @@ -101,7 +101,7 @@ private theorem colourValueRank_injective : cases x with | inl a => cases y with - | inl b => simp? [colourValueRank] at hxy; exact congrArg Sum.inl (Fin.ext + | inl b => simp [colourValueRank] at hxy; exact congrArg Sum.inl (Fin.ext hxy) | inr b => simp [colourValueRank] at hxy; omega | inr a => @@ -170,7 +170,7 @@ private theorem vr_comp_sigma_mono {d : ℕ} (c : MixedColouring k ℓ d) (_hd : have hsi := si.isLt; have hsj := sj.isLt nlinarith --- Raised budget: monotonicity is checked on all four +-- 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 * ℓ))) : @@ -526,7 +526,7 @@ private theorem canonSortPerm_sign {d : ℕ} (c : MixedColouring k ℓ d) apply Fin.ext show a.val = b.val have := congrArg Fin.val hinj - simp? at this; exact this + simp 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 => @@ -640,7 +640,7 @@ private theorem canonSortPerm_sign {d : ℕ} (c : MixedColouring k ℓ d) canonColouring (evenMultisetOf c) F (finCongr h (σ.symm q)) from congr_fun comp _] unfold canonColouring - rw [dite_eq_left (by simp? [finCongr_apply]; exact hq_low)] + rw [dite_eq_left (by simp [finCongr_apply]; exact hq_low)] exact Sum.getRight?_inl -- Step 3c: structural claim have step3 : oddListOf c = List.ofFn (v ∘ π) := by @@ -668,7 +668,7 @@ private theorem canonSortPerm_sign {d : ℕ} (c : MixedColouring k ℓ d) /-! ## Main theorem -/ --- Raised budget: the permutation, its arity equality and its sign +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapClosed.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapClosed.lean index bf5ff69d6c..0d392c2f68 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapClosed.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapClosed.lean @@ -28,7 +28,7 @@ variable {R : ℕ} (f : EdgeRankParameter R) variable (P : DelignePackage (SkeinObj f)) variable {k ℓ : ℕ} --- Raised budget: the cap value is computed on a basis vector +-- 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.** -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeelSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeelSplit.lean index 04be7056d8..a631143d2a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeelSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapPeelSplit.lean @@ -92,7 +92,7 @@ theorem splitCapVal_merge (m : ℕ) SuperVect.Hom _ _).evenMap y) := omegaFun_capTensor_merge f P e m x y --- Raised budget: the merge of an odd pair is pushed through the +-- 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 : ℕ) @@ -152,7 +152,7 @@ theorem splitCapVal_oddMerge (m : ℕ) exact omegaFun_tensor_oddPair f P (bundleCapClass f m) (evClass f) _ _ --- Raised budget: peeling one cap rewrites the transport along a +-- 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 : ℕ) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapSplit.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapSplit.lean index 5a971b8b14..f2a5756417 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapSplit.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CapSplit.lean @@ -29,7 +29,7 @@ variable (P : DelignePackage (SkeinObj f)) variable {k ℓ : ℕ} variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) --- Raised budget: multiplicativity is checked by unfolding the +-- 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 : ℕ) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleModel.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleModel.lean index f4076c05f7..9494dd8b2e 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleModel.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CircleModel.lean @@ -90,7 +90,7 @@ theorem coev_comp_ev : variable (P : DelignePackage (SkeinObj f)) --- Raised budget: the circle value is read off the standard form +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoreParity.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoreParity.lean index b6d0c28bae..0d06043924 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoreParity.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CoreParity.lean @@ -329,7 +329,7 @@ theorem core_parity (W : ClosedFragment) _ = (-1 : ℂ) ^ κ.circuitCount := by rw [hs, ← hout_card, hG] --- Raised budget: four sign families — pattern, crossing, +-- 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, diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvLeaf.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvLeaf.lean index 7b80aa51b0..a10eff0ce8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvLeaf.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/EvLeaf.lean @@ -50,7 +50,7 @@ theorem stdForm_oddPair (x y : (stdSuperPair k ℓ).odd) : rw [LinearMap.coprod_apply, map_zero, zero_add] exact TensorProduct.lift.tmul x y --- Raised budget: the evaluation is computed on a two-position +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FibreParam.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FibreParam.lean index dde38840d3..8727159ec3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FibreParam.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/FibreParam.lean @@ -428,7 +428,7 @@ noncomputable def oddColouringOf (W : ClosedFragment) ⟨oddDataOf W F c hfibre, oddDataOf_constancy W F c hfibre⟩ --- Raised budget: reconstruction is checked slot by slot, each slot +-- 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MasterSum.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MasterSum.lean index ea81f77a32..a80c8f9f7d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MasterSum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/MasterSum.lean @@ -29,7 +29,7 @@ variable {k ℓ : ℕ} variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) --- Raised budget: the parameter is rewritten as a colour sum, which +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelCoord.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelCoord.lean index 43fb66d3e4..0d677239fd 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelCoord.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelCoord.lean @@ -60,7 +60,7 @@ variable {R : ℕ} (f : EdgeRankParameter R) variable (P : DelignePackage (SkeinObj f)) variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) --- Raised budget: the coordinate factorisation is proved by +-- 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.** -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelStarVec.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelStarVec.lean index 25698f2dda..c1fe0287ed 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelStarVec.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ModelStarVec.lean @@ -48,7 +48,7 @@ noncomputable def modelStarVec : SuperVect.Hom _ _).evenMap (starVec f P d)) (modelStarVec ds))) --- Raised budget: the transport is compared with the assembled star +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFDef.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFDef.lean index 9efc2381a3..385e2b8bfa 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFDef.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFDef.lean @@ -30,7 +30,7 @@ variable {k ℓ : ℕ} /-! ## The h-generic master summand -/ --- Raised budget: the definition names the sorted colouring, its +-- The definition names the sorted colouring, its -- block restrictions and their odd lists, so the whole star -- enumeration elaborates here. open Classical in @@ -63,7 +63,7 @@ noncomputable def hMaster (h : MixedFunctional k ℓ) /-! ## Per-vertex value lemmas -/ --- Raised budget: the block factor is matched with the vertex +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFValue.lean index 0cfb489485..0d4503546d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFValue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/NFValue.lean @@ -27,7 +27,7 @@ variable {k ℓ : ℕ} /-! ## The h-generic value identity -/ --- Raised budget: the master summand of the flipped data colouring +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddPair.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddPair.lean index fb961a5a7e..8bd94a7b28 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddPair.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddPair.lean @@ -62,7 +62,7 @@ theorem lambda_oddPair variable {R : ℕ} (f : EdgeRankParameter R) variable (P : DelignePackage (SkeinObj f)) --- Raised budget: the vanishing is checked through the tensorator +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean index 071e5dea28..85088dedb3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean @@ -152,7 +152,7 @@ theorem prod_oddSignAt (o : κ.Orientation) (φ : F.OddColouring ℓ) : congr 1; ext f simp only [e, Equiv.coe_fn_mk] rw [o.match_flip _ f.prop] - cases hb : o.isOut f.val <;> simp? + cases hb : o.isOut f.val <;> simp · unfold EdgeSubset.oddSignFn congr 1 exact congrArg φ.val (Subtype.ext (κ.match_invol _ f.prop)) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaCotensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaCotensor.lean index 1ab8debff9..cc3a55a9a5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaCotensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaCotensor.lean @@ -90,7 +90,7 @@ theorem lambda_evenPair {V W : SuperVect} ((h : SuperVect.Hom _ _).evenMap w) from rfl] exact TensorProduct.lid_tmul _ _ --- Raised budget: monoidality of the image functional unfolds the +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean index 47b93b8548..cd5bc75279 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OmegaTensor.lean @@ -120,7 +120,7 @@ theorem superVect_leftUnitor_inv_one : (1 : ℂ) ⊗ₜ[ℂ] (1 : ℂ) from TensorProduct.lid_symm_apply 1] rfl --- Raised budget: monoidality of the image vector unfolds the +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OneBasis.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OneBasis.lean index 1119ae75b4..786237cc8a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OneBasis.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OneBasis.lean @@ -92,7 +92,7 @@ private theorem oddSplit0_inr (c : MixedColouring k ℓ 1) exact (colouringSplit_symm_last _ _).trans ha.symm rw [← inv, Equiv.apply_symm_apply] --- Raised budget: the one-position basis vector is identified +-- 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.** -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ParameterModel.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ParameterModel.lean index 638b755686..207ec42a5d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ParameterModel.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ParameterModel.lean @@ -60,7 +60,7 @@ theorem stdToOmega_bmc_perm_all : rw [Category.comp_id, Category.id_comp] | n + 1, σ => stdToOmega_bmc_perm f P e σ --- Raised budget: the parameter is rewritten over the model, so the +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PowMerge.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PowMerge.lean index bf2a4f1375..eea1fe66d5 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PowMerge.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/PowMerge.lean @@ -38,7 +38,7 @@ variable (P : DelignePackage (SkeinObj f)) variable {k ℓ : ℕ} variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) --- Raised budget: the block transport is proved by recursion on the +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean index c1479a9e55..9b32f85d73 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean @@ -458,7 +458,7 @@ private noncomputable def globalBase (W : ClosedFragment) (F : EdgeSubset W) /-! ## FlatMap decompositions -/ --- Raised budget: the two flat-map presentations are matched edge +-- 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) @@ -674,7 +674,7 @@ private theorem getElem_val_irrel {α : Type*} (l : List α) {a b : Nat} /-! ## Half 1: sign of oriented → matched = sign of outPerm -/ --- Raised budget: the index permutation between the two lists is +-- 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} @@ -1092,7 +1092,7 @@ theorem sign_listIndexPerm_matched_global (W : ClosedFragment) (F : EdgeSubset 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? at this; exact this + have := Option.some.inj hM2k_even; simp 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 _ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexBij.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexBij.lean index 449dce82b6..53f125efe3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexBij.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexBij.lean @@ -87,7 +87,7 @@ private theorem evenColouringOf_congr (W : ClosedFragment) evenColouringOf W F c₂ h₂ hd₂ := by subst h; rfl --- Raised budget: the fibre sum is reindexed along the +-- 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.** -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexHeart.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexHeart.lean index 0cc6a5f4db..5640c3190b 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexHeart.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexHeart.lean @@ -31,7 +31,7 @@ variable {k ℓ : ℕ} variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) --- Raised budget: the termwise identity assembles the star +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexVanish.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexVanish.lean index 041557be2d..9111d0dc50 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexVanish.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/ReindexVanish.lean @@ -106,7 +106,7 @@ theorem colourFormEntry_inr_ne {u v : Fin (2 * ℓ)} colourFormEntry k ℓ (Sum.inr u) (Sum.inr v) = 0 := by rw [colourFormEntry_odd, stdFormOdd_stdF, ite_eq_right h] --- Raised budget: the vanishing is located at one off-diagonal +-- 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SkeinPowBraid.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SkeinPowBraid.lean index 9861847d4c..5ec2ac8e76 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SkeinPowBraid.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/SkeinPowBraid.lean @@ -113,7 +113,7 @@ variable (P : DelignePackage (SkeinObj f)) variable {k ℓ : ℕ} variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) --- Raised budget: the intertwining is proved by recursion on the +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPerm.lean index 04b3d94270..0e45e3e0ac 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StarPerm.lean @@ -67,7 +67,7 @@ theorem stdFromOmega_perm rw [stdFromOmega_stdToOmega f P e e' hee' d] rw [Category.id_comp] --- Raised budget: `rfl`, but the two sides agree only after the +-- `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 : ℕ) @@ -76,7 +76,7 @@ theorem starCoord_eq_coordOf (d : ℕ) coordOf (((stdFromOmega f P e' d) : SuperVect.Hom _ _).evenMap (starVec f P d)) c := rfl --- Raised budget: the symmetry is read through the transport and +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StrandTransport.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StrandTransport.lean index 79cde3a3c3..b3a3f9d247 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StrandTransport.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/StrandTransport.lean @@ -53,7 +53,7 @@ theorem stdToOmega_one : rw [Category.comp_id] at h exact h --- Raised budget: the one-strand transport is unfolded through the +-- 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TopBraidMerge.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TopBraidMerge.lean index 92c88efbd1..1ca99a9c74 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TopBraidMerge.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/TopBraidMerge.lean @@ -42,7 +42,7 @@ private theorem topB_natural rw [associator_naturality_left_assoc, ← whisker_exchange_assoc, associator_inv_naturality_left] --- Raised budget: the exchange is a coherence computation in an +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexSign.lean index be5c0d43c6..f18d1c09c0 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexSign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexSign.lean @@ -26,7 +26,7 @@ open Finset variable {k ℓ : ℕ} --- Raised budget: two sorting signs are matched with the key sign of +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexValue.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexValue.lean index fc5127c4e3..14d91ed49f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexValue.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/VertexValue.lean @@ -31,7 +31,7 @@ variable {k ℓ : ℕ} variable (e : stdSuperPair k ℓ ⟶ P.ω.obj (SkeinObj.mk 1)) variable (e' : P.ω.obj (SkeinObj.mk 1) ⟶ stdSuperPair k ℓ) --- Raised budget: the block's star coordinate is computed through +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean index 238ea2c6b2..c57f4db3e8 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockCycle.lean @@ -116,7 +116,7 @@ theorem blockTensorEnd_mul {a b : ℕ} /-! ### The rotation step at fragments -/ --- Raised budget: five fragment equivalences are chained on each +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactor.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactor.lean index e44da33980..8959e23d4d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactor.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/BlockFactor.lean @@ -178,7 +178,7 @@ private theorem blockTensorEnd_one_right (x : skeinEnd f a) : (blockTensorEnd f x (1 : skeinEnd f 0))).symm.trans (h.trans (HomSpace.comp_id_left f a a x)) --- Raised budget: associativity is stated up to an arity cast, so +-- 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 : ℕ} @@ -379,7 +379,7 @@ private theorem blockPerm_sumCongr (n : ℕ) {a b : ℕ} /-! ### Braiding commutativity at block arities -/ --- Raised budget: the commutation is checked at the HomSpace level, +-- 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. -/ @@ -595,7 +595,7 @@ private theorem swap01_comm_blockPow2 (g : skeinEnd f n) : (blockPow f n g 1) from blockPow_split f n g 1 1] exact blockSwap01_comm f (n * 1) (blockPow f n g 1) --- Raised budget: the induction on the block count carries the +-- 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 : ℕ) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGenerator.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGenerator.lean index e5bd7d79ab..64616a8561 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGenerator.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/EnvGenerator.lean @@ -232,7 +232,7 @@ noncomputable def envMatDecomp (A : Mat_ (Karoubi (SkeinObj f))) : /-! ### The generator field -/ --- Raised budget: the retract is built from a finite biproduct +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiMonoidal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiMonoidal.lean index 5db0e3fe2c..687ee1ee68 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/KaroubiMonoidal.lean @@ -533,7 +533,7 @@ 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)`. -/ --- Raised budget: the eight coherence fields of a monoidal functor +-- The eight coherence fields of a monoidal functor -- elaborate together. /-- The embedding is monoidal. -/ noncomputable instance toKaroubiMonoidal @@ -650,7 +650,7 @@ noncomputable def karoubiBraidingIso (𝟙 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 --- Raised budget: naturality on both sides and both hexagons +-- 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean index 3b22d0ac66..c1556099dd 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatBraided.lean @@ -128,7 +128,7 @@ open scoped Classical in /-! ### Braiding iso -/ --- Raised budget: the matrix identity is checked entrywise, and +-- 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] @@ -187,7 +187,7 @@ def matBraidIso [Category.{v} C] [Preadditive C] [MonoidalCategory C] /-! ### Braiding naturality -/ --- Raised budget: naturality is checked entrywise, each entry a sum +-- 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] @@ -310,7 +310,7 @@ private theorem mat_comp3_rev_rhs congr 1; ext dx; rw [Preadditive.comp_sum] congr 1; ext dz; rw [Preadditive.comp_sum] --- Raised budget: the hexagon is checked entrywise on a triple +-- 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] @@ -448,7 +448,7 @@ end Braided section Symmetric --- Raised budget: symmetry is checked entrywise. +-- Symmetry is checked entrywise. /-- And a symmetric one stays symmetric. -/ instance matSymmetric [Category.{v} C] [Preadditive C] [MonoidalCategory C] [MonoidalPreadditive C] [SymmetricCategory C] : diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean index cef423ce08..0a3ba43525 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatEmbMonoidal.lean @@ -145,7 +145,7 @@ private theorem mat_assocHom_apply' (K.X k')).hom else 0 else 0 else 0 := rfl --- Raised budget: associativity of the embedding is checked +-- Associativity of the embedding is checked -- entrywise on a triple index. private theorem matEmb_associativity [Category.{v} C] [Preadditive C] [MonoidalCategory C] @@ -268,7 +268,7 @@ private theorem mat_rightUnitorHom_apply' if h : i = k then eqToHom (by subst h; rfl) ≫ (ρ_ (M.X k)).hom else 0 := rfl --- Raised budget: unitality is checked entrywise against the +-- Unitality is checked entrywise against the -- one-object index. private theorem matEmb_left_unitality [Category.{v} C] [Preadditive C] [MonoidalCategory C] @@ -436,7 +436,7 @@ private theorem mat_braidHom_apply' eqToHom (by subst hi; subst hj; rfl) ≫ (β_ (M.X j₂) (N.X j₁)).hom else 0 else 0 := rfl --- Raised budget: the braided axiom is checked entrywise through +-- The braided axiom is checked entrywise through -- the tensorator. private theorem matEmb_braided [Category.{v} C] [Preadditive C] [MonoidalCategory C] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean index 70c43dfe42..c9ff460ed6 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatMonoidal.lean @@ -421,7 +421,7 @@ 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`. -/ --- Raised budget: the pentagon is checked entrywise on a quadruple +-- The pentagon is checked entrywise on a quadruple -- index, so four matrix compositions expand. open scoped Classical in private theorem mat_pentagon diff --git a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean index 28c79b0daa..1eb73a590a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Envelope/MatRigid.lean @@ -178,7 +178,7 @@ private theorem matEv_apply_off /-! ### The snake identities -/ --- Raised budget: the snake identity is checked entrywise, and the +-- 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] diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean index 0667e6b906..579edd9621 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean @@ -99,7 +99,7 @@ private theorem std_coev_ev (k ℓ : ℕ) : (TensorProduct.lid ℂ (Fin k → ℂ)).symm.toLinearMap) ∘ₗ ((TensorProduct.rid ℂ (Fin k → ℂ)).toLinearMap ∘ₗ LinearMap.fst ℂ _ _) ext x - all_goals simp? [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, + all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, stdCopairOddElem, mk_sum_split, mk_sum_left, mk_add_left, mk_smul_left, mk_smul_right, @@ -137,7 +137,7 @@ private theorem std_coev_ev (k ℓ : ℕ) : ((TensorProduct.rid ℂ (Fin (2 * ℓ) → ℂ)).toLinearMap ∘ₗ LinearMap.snd ℂ _ _) ext x - all_goals simp? [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, + all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, stdCopairOddElem, mk_sum_split, mk_sum_left, mk_sum_right, mk_add_right, mk_smul_left, mk_smul_right, @@ -203,7 +203,7 @@ private theorem std_ev_coev (k ℓ : ℕ) : (TensorProduct.rid ℂ (Fin k → ℂ)).symm.toLinearMap) ∘ₗ ((TensorProduct.lid ℂ (Fin k → ℂ)).toLinearMap ∘ₗ LinearMap.fst ℂ _ _) ext x - all_goals simp? [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, + all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, stdCopairOddElem, mk_sum_split, mk_sum_left, mk_add_left, mk_smul_left, mk_smul_right, @@ -241,7 +241,7 @@ private theorem std_ev_coev (k ℓ : ℕ) : ((TensorProduct.lid ℂ (Fin (2 * ℓ) → ℂ)).toLinearMap ∘ₗ LinearMap.fst ℂ _ _) ext x - all_goals simp? [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, + all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, stdCopairOddElem, mk_sum_split, mk_sum_left, mk_sum_right, mk_add_left, mk_smul_left, mk_smul_right, diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleClose.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleClose.lean index 40481b4730..e33a2855af 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleClose.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/BundleClose.lean @@ -511,7 +511,7 @@ theorem lift_eq_mapPairs : attribute [instance] matchPairs_surv_isEmpty --- Raised budget: the closure is matched with the self-glue along +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean index 03c8a885d8..764de09872 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean @@ -100,7 +100,7 @@ theorem oddListAt_map (e : MixedColourEmbedding k ℓ K L) rw [List.map_flatMap] congr 1 funext a - simp? [EdgeSubset.oddPairFn, oddColouring, e.partner_eq] + simp [EdgeSubset.oddPairFn, oddColouring, e.partner_eq] exact ⟨rfl, rfl⟩ /-- The odd vertex sign is preserved by embedding colours. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseFamily.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseFamily.lean index 7fba06bb70..8e157ca851 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseFamily.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseFamily.lean @@ -862,7 +862,7 @@ theorem match_pushData_liftData_bitsOf {k ℓ : ℕ} : ∀ (n : ℕ) (fun a => x a.castSucc) _ hct' hEt hnet (hbits' ▸ hal.2) (stage_matches_of_matches n V hcl s hc x hbm) --- Raised budget: the round trip is followed through one stage of +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseLift.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseLift.lean index 74ea247cce..8caa2f7959 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseLift.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseLift.lean @@ -395,7 +395,7 @@ theorem match_pushData_liftData_succ_open_at (n : ℕ) (match_unglue_glueDataOpen (cutL_ne_cutR n) hop 𝒟 hc hE hne hdc hcL hEL hneL hag f hf) --- Raised budget: as for the directions, on the matching. +-- 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean index 6738864ce3..025c8e722d 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean @@ -55,12 +55,12 @@ def symm (e : Equiv W₁ W₂) : Equiv W₂ W₁ where vertexEquiv := e.vertexEquiv.symm attach_comm := fun f => by have h := e.attach_comm (e.flagEquiv.symm f) - simp? at h + simp 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? at h + simp at h rw [← h] simp circles_eq := e.circles_eq.symm @@ -70,11 +70,11 @@ def trans (e₁ : Equiv W₁ W₂) (e₂ : Equiv W₂ W₃) : Equiv W₁ W₃ wh flagEquiv := e₁.flagEquiv.trans e₂.flagEquiv vertexEquiv := e₁.vertexEquiv.trans e₂.vertexEquiv attach_comm := fun f => by - simp? [_root_.Equiv.trans_apply] + simp [_root_.Equiv.trans_apply] rw [e₂.attach_comm, e₁.attach_comm] rcases W₁.attach f with v | ℓ <;> simp pairing_comm := fun f => by - simp? [_root_.Equiv.trans_apply] + simp [_root_.Equiv.trans_apply] rw [e₁.pairing_comm, e₂.pairing_comm] circles_eq := e₁.circles_eq.trans e₂.circles_eq @@ -163,11 +163,11 @@ def survivingFlagEquiv (e : Equiv W₁ W₂) (i j : α) : 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? at h1 + simp at h1 rw [e.boundaryFlag_comm i] at h1 exact h1 · have h1 := congrArg e.flagEquiv h - simp? at h1 + simp at h1 rw [e.boundaryFlag_comm j] at h1 exact h1⟩ left_inv f := Subtype.ext (by simp) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean index 6e080a7679..30188a5a7a 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean @@ -402,7 +402,7 @@ private theorem interfaceStepEquiv_symm_inr_below (s t u : ℕ) (j : Fin (t + u) simp only [finRemoveEquiv, Equiv.coe_fn_symm_mk] rw [finSuccEquiv'_symm_some_below] · simp [Fin.castSucc] - · simp? [Fin.lt_def, Fin.castSucc]; exact hj + · simp [Fin.lt_def, Fin.castSucc]; exact hj private theorem interfaceStepEquiv_symm_inr_above (s t u : ℕ) (j : Fin (t + u)) (hj : ¬ j.val < t) : @@ -481,7 +481,7 @@ noncomputable abbrev sourceFragment (t t' u : ℕ) (ht : t' + 1 ≤ t) (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) --- Raised budget: the four equivalence fields are checked against +-- 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))) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceShift.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceShift.lean index 87357425a1..a074bbe504 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceShift.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceShift.lean @@ -266,7 +266,7 @@ noncomputable def shiftLabelR (s : ℕ) {t : ℕ} List.Perm.refl _)).symm.trans ((interfaceSurvEquiv s t u).trans finSumFinEquiv)))) --- Raised budget: normalising the shifted side chains the glue-list +-- Normalising the shifted side chains the glue-list -- presentation with two relabels. /-- The shifted left side, normalized. -/ noncomputable def shiftNormalLeft {s t u : ℕ} diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean index 028385cb15..884d575097 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean @@ -420,7 +420,7 @@ ledger reads neither the orientation nor which proof of the pairing record is supplied. -/ --- Raised budget: the ledger of the stepped data is computed, so +-- 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 @@ -502,7 +502,7 @@ instance stageEmpty : IsEmpty (Fin (0 + 0) ⊕ Fin (0 + 0)) := | Sum.inl a => a.elim0 | Sum.inr b => b.elim0⟩ --- Raised budget: the recursion on the cut count carries the whole +-- 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 : ℕ) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean index 050fad2cde..0fbcdd5bea 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean @@ -86,9 +86,9 @@ theorem exists_involution_of_even {β : Type} · rw [h2, hm_b]; exact ha · rw [hm_other x h1 h2] have hxs' : x ∈ s' := by - simp? [hs'_def, Finset.mem_erase]; exact ⟨h2, h1, hx⟩ + simp [hs'_def, Finset.mem_erase]; exact ⟨h2, h1, hx⟩ have := hm'_mem x hxs' - simp? [hs'_def, Finset.mem_erase] at this; exact this.2.2 + simp [hs'_def, Finset.mem_erase] at this; exact this.2.2 · -- m is an involution on s intro x hx by_cases h1 : x = a @@ -97,7 +97,7 @@ theorem exists_involution_of_even {β : Type} · rw [h2, hm_b, hm_a] · rw [hm_other x h1 h2] have hxs' : x ∈ s' := by - simp? [hs'_def, Finset.mem_erase]; exact ⟨h2, h1, hx⟩ + simp [hs'_def, Finset.mem_erase]; 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] @@ -110,7 +110,7 @@ theorem exists_involution_of_even {β : Type} · rw [h2, hm_b] at hfp; exact hab hfp · rw [hm_other x h1 h2] at hfp have hxs' : x ∈ s' := by - simp? [hs'_def, Finset.mem_erase]; exact ⟨h2, h1, hx⟩ + simp [hs'_def, Finset.mem_erase]; exact ⟨h2, h1, hx⟩ exact hm'_ne x hxs' hfp /-! ### Part 1: constructing the transition system -/ From 3af8182b1c7eb4a16148a2a6b910fdbcace26f35 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Sat, 26 Sep 2026 05:11:12 +0000 Subject: [PATCH 41/46] fix(RegtsSevenster): close skein visibility and explicit simp frontiers --- .../RS/Classical/Deligne/ModIns.lean | 14 ++- .../RS/Classical/Deligne/ModTensor.lean | 11 +- .../RS/Classical/Deligne/SuperRealize.lean | 4 +- .../RS/Classical/SchurTheory/JTPad.lean | 2 +- .../Classical/SchurTheory/SignedTensor.lean | 2 +- .../RS/Classical/SchurTheory/SimpleEmbed.lean | 3 +- LeanPool/RegtsSevenster/RS/Definitions.lean | 6 +- .../RS/Novel/Coordinates/CanonPerm.lean | 6 +- .../RS/Novel/Coordinates/OddSignProd.lean | 3 +- .../RS/Novel/Coordinates/RegroupSign.lean | 2 +- .../RS/Novel/Extraction/StdRigid.lean | 101 ++++++++++-------- .../RS/Novel/Skein/ColourPadding.lean | 3 +- .../RS/Novel/Skein/FragmentEquiv.lean | 12 +-- .../RS/Novel/Skein/IdentityLaw.lean | 2 +- .../RS/Novel/Skein/InterfaceCut.lean | 1 + .../RS/Novel/Skein/OrientExistence.lean | 46 ++++---- .../RS/Novel/Skein/PairedAssembly.lean | 6 +- .../RS/Novel/Skein/TransitionExists.lean | 8 +- 18 files changed, 134 insertions(+), 98 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean index 60f3bfa467..a05dcb7fe2 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModIns.lean @@ -53,22 +53,28 @@ theorem append_pair_slot_cases rcases post.eq_nil_or_concat with h | ⟨post', q, rfl⟩ · subst h have := congrArg List.reverse hd - simp at this + 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 at this + 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 at h4 + 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 at this + 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 = diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean index dd57102015..ce6d5be2a0 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/ModTensor.lean @@ -243,7 +243,9 @@ lemma actLeft_actRight [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (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 [actRight, actLeft_actLeft] + 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 @@ -254,7 +256,10 @@ lemma actRight_actRight [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] (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 [actRight, actLeft_actLeft] + 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 @@ -943,7 +948,7 @@ lemma modTensorAct_map [Category.{v} D] [MonoidalCategory D] (A : D) [MonObj A] 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 + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean index c8883defb9..f202cd0f98 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/Deligne/SuperRealize.lean @@ -692,7 +692,9 @@ theorem unitHomMul_assoc R ◁ R ◁ c ≫ R ◁ μ[R] ≫ μ[R] := by rw [rightUnitor_inv_naturality_assoc, ← whisker_exchange_assoc, MonObj.mul_assoc, associator_naturality_right_assoc] - simp [unitHomMul, tensorHom_def] + 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] diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean index 47adfd0331..57b5b415de 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/JTPad.lean @@ -260,7 +260,7 @@ theorem colourChar_extend_zero {n N k : ℕ} (hNk : N ≤ k) constructor · intro h have := congrArg Fin.val h - simp [Fin.val_castLE] at this + 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 diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean index f8a43c1df4..b6d39c604c 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SignedTensor.lean @@ -70,7 +70,7 @@ theorem sign_mul_cycleProd_const {n : ℕ} (m : ℕ) set K := c + (n - s) have hsn : s ≤ n := by have := Equiv.Perm.sum_cycleType_le π - simp [Fintype.card_fin] at this + 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 := diff --git a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean index 1d06280376..6b60d0ac41 100644 --- a/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean +++ b/LeanPool/RegtsSevenster/RS/Classical/SchurTheory/SimpleEmbed.lean @@ -48,7 +48,8 @@ theorem exists_simple_submodule_linearEquiv [Group G] [Finite G] have h1 : φ 1 ∈ range φ := mem_range_self φ 1 have h1bot := h h1 rw [Submodule.mem_bot] at h1bot - simp [φ, toSpanSingleton, smulRight] 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 diff --git a/LeanPool/RegtsSevenster/RS/Definitions.lean b/LeanPool/RegtsSevenster/RS/Definitions.lean index d0e9fc2db6..7a988aa1a7 100644 --- a/LeanPool/RegtsSevenster/RS/Definitions.lean +++ b/LeanPool/RegtsSevenster/RS/Definitions.lean @@ -182,7 +182,8 @@ def disjUnion (W₁ : Fragment α) (W₂ : Fragment β) : | inl ℓ₁ => cases f with | inl g => - rcases ha : W₁.attach g with v | ℓ' <;> simp [ha] at h + 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 => @@ -192,7 +193,8 @@ def disjUnion (W₁ : Fragment α) (W₂ : Fragment β) : | inl g => rcases ha : W₁.attach g with v | ℓ' <;> simp [ha] at h | inr g => - rcases ha : W₂.attach g with v | ℓ' <;> simp [ha] at h + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean index 2183961f09..b516ac4be9 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/CanonPerm.lean @@ -101,7 +101,7 @@ private theorem colourValueRank_injective : cases x with | inl a => cases y with - | inl b => simp [colourValueRank] at hxy; exact congrArg Sum.inl (Fin.ext + | inl b => simp only [colourValueRank] at hxy; exact congrArg Sum.inl (Fin.ext hxy) | inr b => simp [colourValueRank] at hxy; omega | inr a => @@ -526,7 +526,7 @@ private theorem canonSortPerm_sign {d : ℕ} (c : MixedColouring k ℓ d) apply Fin.ext show a.val = b.val have := congrArg Fin.val hinj - simp at this; exact this + 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 => @@ -640,7 +640,7 @@ private theorem canonSortPerm_sign {d : ℕ} (c : MixedColouring k ℓ d) canonColouring (evenMultisetOf c) F (finCongr h (σ.symm q)) from congr_fun comp _] unfold canonColouring - rw [dite_eq_left (by simp [finCongr_apply]; exact hq_low)] + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean index 85088dedb3..8a435f0d4c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/OddSignProd.lean @@ -152,7 +152,8 @@ theorem prod_oddSignAt (o : κ.Orientation) (φ : F.OddColouring ℓ) : congr 1; ext f simp only [e, Equiv.coe_fn_mk] rw [o.match_flip _ f.prop] - cases hb : o.isOut f.val <;> simp + 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)) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean index 9b32f85d73..9971aa3d75 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Coordinates/RegroupSign.lean @@ -1092,7 +1092,7 @@ theorem sign_listIndexPerm_matched_global (W : ClosedFragment) (F : EdgeSubset 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 at this; exact this + 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 _ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean index 579edd9621..024886662f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean @@ -99,17 +99,20 @@ private theorem std_coev_ev (k ℓ : ℕ) : (TensorProduct.lid ℂ (Fin k → ℂ)).symm.toLinearMap) ∘ₗ ((TensorProduct.rid ℂ (Fin k → ℂ)).toLinearMap ∘ₗ LinearMap.fst ℂ _ _) ext x - all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, - stdCopairOddElem, - mk_sum_split, mk_sum_left, mk_add_left, - mk_smul_left, mk_smul_right, - equiv_zero, lmap_zero, - TensorProduct.tmul_add, TensorProduct.tmul_sum, - TensorProduct.sum_tmul, - TensorProduct.tmul_smul, - Prod.fst_sum, Prod.snd_sum, Prod.fst_add, Prod.snd_add, - stdFormEvenBilin, stdFormOddBilin, - stdFormEven, stdE, stdF, stdG] + 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_add, Prod.fst_sum, Prod.smul_fst, 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_add, Prod.snd_sum, Prod.smul_snd, zero_add, + 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) = @@ -137,16 +140,21 @@ private theorem std_coev_ev (k ℓ : ℕ) : ((TensorProduct.rid ℂ (Fin (2 * ℓ) → ℂ)).toLinearMap ∘ₗ LinearMap.snd ℂ _ _) ext x - all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, - stdCopairOddElem, - mk_sum_split, mk_sum_left, mk_sum_right, - mk_add_right, mk_smul_left, mk_smul_right, - equiv_zero, lmap_zero, - TensorProduct.tmul_add, TensorProduct.tmul_sum, - TensorProduct.tmul_smul, - Prod.fst_sum, Prod.snd_sum, Prod.fst_add, Prod.snd_add, - stdFormEvenBilin, stdFormOddBilin, - stdFormOdd, stdE, stdF, stdG] + 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_add, 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_add, Prod.snd_sum, Prod.smul_snd, smul_zero, add_zero, + mk_sum_left, mk_smul_left, TensorProduct.rid_tmul] have hinner : ∀ m : Fin (2 * ℓ), (-∑ n, (oddPartnerSign ℓ n : ℂ) * (Pi.single x (1 : ℂ) : Fin (2 * ℓ) → ℂ) n * @@ -203,17 +211,21 @@ private theorem std_ev_coev (k ℓ : ℕ) : (TensorProduct.rid ℂ (Fin k → ℂ)).symm.toLinearMap) ∘ₗ ((TensorProduct.lid ℂ (Fin k → ℂ)).toLinearMap ∘ₗ LinearMap.fst ℂ _ _) ext x - all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, - stdCopairOddElem, - mk_sum_split, mk_sum_left, mk_add_left, - mk_smul_left, mk_smul_right, - equiv_zero, lmap_zero, - TensorProduct.tmul_sum, - TensorProduct.add_tmul, TensorProduct.sum_tmul, - TensorProduct.tmul_smul, TensorProduct.smul_tmul, - Prod.fst_sum, Prod.snd_sum, Prod.fst_add, Prod.snd_add, - stdFormEvenBilin, stdFormOddBilin, - stdFormEven, stdE, stdF, stdG] + 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_add, Prod.fst_sum, + Prod.smul_fst, 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_add, Prod.snd_sum, Prod.smul_snd, zero_add, + 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) = @@ -241,16 +253,21 @@ private theorem std_ev_coev (k ℓ : ℕ) : ((TensorProduct.lid ℂ (Fin (2 * ℓ) → ℂ)).toLinearMap ∘ₗ LinearMap.fst ℂ _ _) ext x - all_goals simp [-Prod.mk_add_mk, -Prod.smul_mk, stdCopairEvenElem, - stdCopairOddElem, - mk_sum_split, mk_sum_left, mk_sum_right, mk_add_left, - mk_smul_left, mk_smul_right, - equiv_zero, lmap_zero, - TensorProduct.add_tmul, TensorProduct.sum_tmul, - TensorProduct.tmul_smul, TensorProduct.smul_tmul, - Prod.fst_sum, Prod.snd_sum, Prod.fst_add, Prod.snd_add, - stdFormEvenBilin, stdFormOddBilin, - stdFormOdd, stdE, stdF, stdG] + 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_add, Prod.fst_sum, + Prod.smul_fst, smul_zero, Finset.sum_const_zero, add_zero, Prod.snd_add, 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, mk_sum_right, + 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 * diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean index 764de09872..102cc2706c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ColourPadding.lean @@ -100,7 +100,8 @@ theorem oddListAt_map (e : MixedColourEmbedding k ℓ K L) rw [List.map_flatMap] congr 1 funext a - simp [EdgeSubset.oddPairFn, oddColouring, e.partner_eq] + 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. -/ diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean index 025c8e722d..7d44341cac 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/FragmentEquiv.lean @@ -55,12 +55,12 @@ def symm (e : Equiv W₁ W₂) : Equiv W₂ W₁ where vertexEquiv := e.vertexEquiv.symm attach_comm := fun f => by have h := e.attach_comm (e.flagEquiv.symm f) - simp at h + 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 at h + simp only [Equiv.apply_symm_apply] at h rw [← h] simp circles_eq := e.circles_eq.symm @@ -70,11 +70,11 @@ def trans (e₁ : Equiv W₁ W₂) (e₂ : Equiv W₂ W₃) : Equiv W₁ W₃ wh flagEquiv := e₁.flagEquiv.trans e₂.flagEquiv vertexEquiv := e₁.vertexEquiv.trans e₂.vertexEquiv attach_comm := fun f => by - simp [_root_.Equiv.trans_apply] + 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 [_root_.Equiv.trans_apply] + simp only [Equiv.trans_apply] rw [e₁.pairing_comm, e₂.pairing_comm] circles_eq := e₁.circles_eq.trans e₂.circles_eq @@ -163,11 +163,11 @@ def survivingFlagEquiv (e : Equiv W₁ W₂) (i j : α) : 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 at h1 + 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 at h1 + 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) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean index 30188a5a7a..7d91b02691 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/IdentityLaw.lean @@ -402,7 +402,7 @@ private theorem interfaceStepEquiv_symm_inr_below (s t u : ℕ) (j : Fin (t + u) simp only [finRemoveEquiv, Equiv.coe_fn_symm_mk] rw [finSuccEquiv'_symm_some_below] · simp [Fin.castSucc] - · simp [Fin.lt_def, Fin.castSucc]; exact hj + · 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) : diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceCut.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceCut.lean index 1628634fd2..8e6c5f8ba4 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceCut.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/InterfaceCut.lean @@ -400,6 +400,7 @@ theorem throughFlags_isEmpty [IsEmpty L] {V : Fragment L} 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientExistence.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientExistence.lean index 381e2b6f22..2c94eb05dc 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientExistence.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/OrientExistence.lean @@ -65,6 +65,7 @@ theorem EdgeSubset.RelTransitionSystem.pathMatch_ne /-- 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 @@ -374,30 +375,27 @@ noncomputable def relBuildOrientation (κ : F.RelTransitionSystem) : if hg : g ∈ F.flags then decide (orbitMin (F.pairingPerm ⟨g, hg⟩) < orbitMin ⟨g, hg⟩) else false - have hmatch_flip : ∀ g ∈ F.internalFlags, - isOut (κ.match_ g) = !isOut g := 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⟩)) - have hpairing_flip : ∀ g ∈ F.internalFlags, - W.pairing g ∈ F.internalFlags → - isOut (W.pairing g) = !isOut g := 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⟩)) - exact ⟨isOut, hmatch_flip, hpairing_flip⟩ + 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean index 48b51d7671..eb361bdaf2 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/PairedAssembly.lean @@ -1985,8 +1985,10 @@ theorem stepStatusLedger 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 + · 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 diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean index 0fbcdd5bea..7bbdb36264 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/TransitionExists.lean @@ -86,9 +86,9 @@ theorem exists_involution_of_even {β : Type} · rw [h2, hm_b]; exact ha · rw [hm_other x h1 h2] have hxs' : x ∈ s' := by - simp [hs'_def, Finset.mem_erase]; exact ⟨h2, h1, hx⟩ + simp only [hs'_def, Finset.mem_erase, ne_eq]; exact ⟨h2, h1, hx⟩ have := hm'_mem x hxs' - simp [hs'_def, Finset.mem_erase] at this; exact this.2.2 + 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 @@ -97,7 +97,7 @@ theorem exists_involution_of_even {β : Type} · rw [h2, hm_b, hm_a] · rw [hm_other x h1 h2] have hxs' : x ∈ s' := by - simp [hs'_def, Finset.mem_erase]; exact ⟨h2, h1, hx⟩ + 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] @@ -110,7 +110,7 @@ theorem exists_involution_of_even {β : Type} · rw [h2, hm_b] at hfp; exact hab hfp · rw [hm_other x h1 h2] at hfp have hxs' : x ∈ s' := by - simp [hs'_def, Finset.mem_erase]; exact ⟨h2, h1, hx⟩ + 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 -/ From 5051613f4d920cee14379c2107df287286f500ed Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Sat, 26 Sep 2026 09:05:06 +0000 Subject: [PATCH 42/46] fix(RegtsSevenster): close empty ledger count and trim unused simp rules --- .../RS/Novel/Extraction/StdRigid.lean | 22 +++++++++---------- .../RS/Novel/Skein/LedgerRecursion.lean | 13 +++++------ 2 files changed, 16 insertions(+), 19 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean index 024886662f..723669ec5c 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Extraction/StdRigid.lean @@ -108,9 +108,9 @@ private theorem std_coev_ev (k ℓ : ℕ) : 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_add, Prod.fst_sum, Prod.smul_fst, smul_zero, Finset.sum_const_zero, add_zero, + 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_add, Prod.snd_sum, Prod.smul_snd, zero_add, + 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] @@ -151,10 +151,10 @@ private theorem std_coev_ev (k ℓ : ℕ) : 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_add, Prod.fst_sum, Finset.sum_const_zero, Prod.smul_fst, zero_add, + 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_add, Prod.snd_sum, Prod.smul_snd, smul_zero, add_zero, - mk_sum_left, mk_smul_left, TensorProduct.rid_tmul] + 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 * @@ -220,10 +220,10 @@ private theorem std_ev_coev (k ℓ : ℕ) : 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_add, Prod.fst_sum, - Prod.smul_fst, smul_zero, Finset.sum_const_zero, add_zero, LinearMap.coprod_apply, + 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_add, Prod.snd_sum, Prod.smul_snd, zero_add, + 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] @@ -262,10 +262,10 @@ private theorem std_ev_coev (k ℓ : ℕ) : 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_add, Prod.fst_sum, - Prod.smul_fst, smul_zero, Finset.sum_const_zero, add_zero, Prod.snd_add, Prod.snd_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, mk_sum_right, + 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 * ℓ), diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean index 884d575097..436a3a91cf 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean @@ -510,14 +510,11 @@ theorem ledger_glueData : ∀ (n : ℕ) stageLedger 0 _ (glueData n V D) + glueCount n V D = stageLedger n V D | 0, V, D => by - have hzero : ∀ {W : Fragment (Fin (0 + 0) ⊕ Fin (0 + 0))} - (F : EdgeSubset W) (M N : DirMatching (UsedLab F)), - DirMatching.unionCount M N = 0 := by - intro W F M N - have : IsEmpty (UsedLab F) := ⟨fun x => isEmptyElim x.val⟩ - exact DirMatching.unionCount_of_isEmpty M N - simp only [glueCount, stageLedger, ledgerOf, glueData, hzero, - Nat.add_zero] + let : IsEmpty (UsedLab D.sub) := ⟨fun x => isEmptyElim x.val⟩ + let : IsEmpty (UsedLab (D.sub.relabelUp endEquiv)) := + ⟨fun x => isEmptyElim x.val⟩ + simp only [glueCount, stageLedger, ledgerOf, glueData, + DirMatching.unionCount_of_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) From c95b922e42dff1ddf0f2869b627c2217cf52e5f4 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Sat, 26 Sep 2026 09:41:47 +0000 Subject: [PATCH 43/46] Reuse the empty-interface ledger lemma in the recursion base case --- .../RS/Novel/Skein/LedgerRecursion.lean | 26 ++++++++----------- 1 file changed, 11 insertions(+), 15 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean index 436a3a91cf..a72b35cb19 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/LedgerRecursion.lean @@ -502,6 +502,16 @@ instance stageEmpty : IsEmpty (Fin (0 + 0) ⊕ Fin (0 + 0)) := | 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.** -/ @@ -510,11 +520,7 @@ theorem ledger_glueData : ∀ (n : ℕ) stageLedger 0 _ (glueData n V D) + glueCount n V D = stageLedger n V D | 0, V, D => by - let : IsEmpty (UsedLab D.sub) := ⟨fun x => isEmptyElim x.val⟩ - let : IsEmpty (UsedLab (D.sub.relabelUp endEquiv)) := - ⟨fun x => isEmptyElim x.val⟩ - simp only [glueCount, stageLedger, ledgerOf, glueData, - DirMatching.unionCount_of_isEmpty, Nat.add_zero] + 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) @@ -554,16 +560,6 @@ theorem ledger_glueData : ∀ (n : ℕ) exact congrArg (fun X => stageLedger 0 _ X + _) hgd] omega -/-- 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] - /-- **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 From d4e06ca7ac806e97ab65cd89cfbda214c534e2fc Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Sat, 26 Sep 2026 10:26:20 +0000 Subject: [PATCH 44/46] Restore local decidability in the relabelled edge sum proof --- LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean | 1 + 1 file changed, 1 insertion(+) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean index 6b47d33e30..3d7dfe2f6f 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/EdgeTerm.lean @@ -1231,6 +1231,7 @@ theorem relabel_edgeSum {α : Type} {β : Type} {W : Fragment α} (ee : α ≃ {κ : 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) : From bead875b4ed849c179049791d3da01e6b331eabf Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Sat, 26 Sep 2026 11:10:35 +0000 Subject: [PATCH 45/46] Supply proof-local decidability for closed boundary agreement --- LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.lean | 1 + 1 file changed, 1 insertion(+) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.lean index 13a0de1f3e..9da31b3f55 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ClosedTopSum.lean @@ -63,6 +63,7 @@ theorem throughAgree_isEmpty {V : Fragment L} [IsEmpty L] (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) From 7a0d769d495c21235617e110989092b9b319f499 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Sat, 26 Sep 2026 12:03:37 +0000 Subject: [PATCH 46/46] Fix Regts-Sevenster formatting warnings Wrap 429 comment lines and 27 lines in existing contract examples, and join four misplaced closing parentheses. Preserve the mathematical content, proof tokens, comment text and project inventory. --- .../RegtsSevenster/RS/Assembly/Blueprint.lean | 675 ++++++++++++------ .../RS/Assembly/BlueprintConverse.lean | 90 ++- .../RS/Assembly/BlueprintDeligne.lean | 60 +- .../RS/Assembly/BlueprintFactorial.lean | 100 ++- .../RS/Assembly/BlueprintSchur.lean | 294 +++++--- .../RS/Assembly/BlueprintStatement.lean | 153 ++-- .../RS/Novel/Skein/ConverseAssembly.lean | 12 +- 7 files changed, 918 insertions(+), 466 deletions(-) diff --git a/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean b/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean index 796fb31b3f..c4e3a4ea81 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/Blueprint.lean @@ -270,9 +270,11 @@ 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.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] -/ +/- Upstream audit output: 'RS.powerSums_zero_of_eventually_zero' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ /-! ### Hook confinement and nilpotent traces @@ -281,11 +283,14 @@ 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.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.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] -/ +/- Upstream audit output: 'RS.isSemisimpleRing_of_trace' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ /-! ### The classical bases @@ -293,9 +298,11 @@ 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_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] -/ +/- Upstream audit output: 'RS.exists_orthonormal_basis' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ /-! ### Definition 5 and its transport @@ -303,9 +310,11 @@ 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.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] -/ +/- Upstream audit output: 'RS.mixedPartition_transport' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ /-! ### The hypothesis class @@ -314,7 +323,8 @@ 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] -/ +/- Upstream audit output: 'RS.edgeRankBounded_iff_submatrixRank' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ /-! ### The gluing calculus @@ -322,23 +332,32 @@ 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.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.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.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.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.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.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.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.Fragment.gluePairComm' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ -/- Upstream audit output: 'RS.composeStrandBundleRight' 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 @@ -346,19 +365,26 @@ 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_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_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_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.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.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.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] -/ +/- Upstream audit output: 'RS.stdForm_comp_stdCopair' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ /-! ### Gluing across a disjoint union @@ -366,50 +392,70 @@ 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.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.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.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.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.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.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_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.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_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_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_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.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.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.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.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.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.interfaceShift' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ -/- Upstream audit output: 'RS.Fragment.pairCloseComm' 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.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] -/ +/- Upstream audit output: 'RS.braided_std_model' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ /-! ### The trace calculus @@ -417,27 +463,38 @@ 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.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.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.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.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.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_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.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.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.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.tensorFragmentUnitLeft' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ -/- Upstream audit output: 'RS.tensorFragmentUnitRight' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +/- Upstream audit output: 'RS.tensorFragmentUnitRight' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ /-! ### The braided envelope @@ -445,13 +502,17 @@ 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.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.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.matBraided' depends on axioms: [propext, Classical.choice, Quot.sound] + -/ -/- Upstream audit output: 'RS.matSymmetric' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +/- Upstream audit output: 'RS.matSymmetric' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ /-! ### The skein category @@ -459,49 +520,71 @@ 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.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.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.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.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.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.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.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.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.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.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.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.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_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.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.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.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.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.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.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.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.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] -/ +/- Upstream audit output: 'RS.star_comp_class' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ /-! ### The coordinate model @@ -509,113 +592,163 @@ 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.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.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.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.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.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.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.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.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.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_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.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.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.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.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_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.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.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.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.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.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.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.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_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.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' 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.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.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.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.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' 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_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.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.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.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_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.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.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.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_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.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.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.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.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.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.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.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.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_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_powBraid' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ -/- Upstream audit output: 'RS.toColour_powBraidWord' 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 @@ -624,183 +757,270 @@ 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.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.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.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.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.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.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.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.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.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.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.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_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.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.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_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.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.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_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.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.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_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.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.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.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.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.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_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.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.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.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.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.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.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.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.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.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' 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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.prod_oddSignAt' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ -/- Upstream audit output: 'RS.betaDiag_colouringOfFlip' 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, +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.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.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.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.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.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.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.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.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.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.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.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_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.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.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.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.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.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_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.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.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.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_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.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.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.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.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.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.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.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.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.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] -/ +/- Upstream audit output: 'RS.mixedValue_eq_summand_closed' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ /-! ### Deligne's hypotheses for the envelope @@ -808,14 +1028,19 @@ 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_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_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_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.env_delignePackage' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ -/- Upstream audit output: 'RS.skein_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 index 29b7cc7571..7d9082b627 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintConverse.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintConverse.lean @@ -26,7 +26,8 @@ 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] -/ +/- 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 @@ -55,19 +56,24 @@ is what the Koszul sign is read from. -- 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.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_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_invol' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ -/- Upstream audit output: 'RS.EdgeSubset.chordInv_ne' 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] -/ +/- 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 @@ -80,13 +86,17 @@ 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_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.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_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] -/ +/- Upstream audit output: 'RS.EdgeSubset.exists_sum_sum_superForm_tensorTermAt' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ /-! ### The interface lift @@ -95,27 +105,38 @@ 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.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.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.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.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.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.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.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.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.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.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] -/ +/- Upstream audit output: 'RS.EdgeSubset.edgeTermAt_pushData_colourSum' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ /-! ### The base sum and the converse @@ -123,19 +144,26 @@ 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.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.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.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.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_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_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] -/ +/- Upstream audit output: 'RS.regts_sevenster_quant_roundtrip' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ /-! ### Definition 5, evaluated @@ -147,6 +175,8 @@ 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_loopGraph' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ -/- Upstream audit output: 'RS.mixedPartition_loopGraphCircle' 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 index b98ff5b7ad..6a489719da 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintDeligne.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintDeligne.lean @@ -24,48 +24,68 @@ namespace RS /-! ### Deligne's theorem -/ -/- Upstream audit output: 'RS.deligne_theorem' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +/- 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.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_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] -/ +/- 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' 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_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_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_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] -/ +/- 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.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.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_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.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.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.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.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.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_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_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] -/ +/- 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 index 969aae591d..bbc354dd46 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintFactorial.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintFactorial.lean @@ -35,14 +35,17 @@ 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 : {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}, +/- 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) -/ + [(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)] → @@ -60,20 +63,29 @@ namespace RS 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) +/- 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] +/- 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] @@ -82,7 +94,8 @@ namespace RS 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] +/- 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] @@ -91,55 +104,74 @@ namespace RS (∀ (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}, +/- 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: @skeinEnd_isSemisimpleRing_factorial : ∀ {R : ℕ} (f : EdgeRankParameter R) + (n : ℕ), IsSemisimpleRing (skeinEnd f n) -/ -/- Upstream audit output: @karoubiEnd_isSemisimpleRing_factorial : ∀ {R : ℕ} (f : EdgeRankParameter R) +/- 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}, + {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: @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: @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_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: @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.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.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.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_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.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_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.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.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.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.karoubiEnd_isSemisimpleRing_factorial' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ -/- Upstream audit output: 'RS.envAbelian' 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 -/ diff --git a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean index 6f2eaa7c60..bccc8dacc4 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintSchur.lean @@ -27,29 +27,40 @@ 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_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_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.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.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.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.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.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.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.restrPairing_ne_zero' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ -/- Upstream audit output: 'RS.schurPackage' 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] -/ +/- Upstream audit output: 'RS.regts_sevenster_deligne_only' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ /-! ### The trace zeta function @@ -58,11 +69,14 @@ 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_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.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] -/ +/- Upstream audit output: 'RS.traceZeta_eq_newtonH_series' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ /-! ### Corollary A.2 with the sharp threshold @@ -70,13 +84,17 @@ 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_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.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.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] -/ +/- Upstream audit output: 'RS.newtonH_series_rational_of_hook_vanishing' depends on axioms: + [propext, Classical.choice, Quot.sound] -/ /-! ### Hook-confined sequences @@ -88,7 +106,8 @@ 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 + P.coeff 0 = 1 ∧ Q.coeff 0 = 1 ∧ P.natDegree ≤ b ∧ Q.natDegree ≤ a ∧ IsCoprime P Q ∧ + RS.newtonHSeries t * ↑Q = ↑P -/ /- @@ -100,7 +119,8 @@ info: RS.superPowerSums_of_hook_vanishing {t : ℕ → ℂ} {a 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 + ∀ (m : ℕ), 1 ≤ m → t m = (Multiset.map (fun x => x ^ m) α).sum - (Multiset.map (fun x + => x ^ m) β).sum -/ /-! ### The separate-sector dimension bound @@ -109,33 +129,47 @@ 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.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.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.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.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.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.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.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.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.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.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.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.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.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] -/ +/- Upstream audit output: 'RS.regts_sevenster_quant_deligne_only' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ /-! ### The total dimension bound @@ -144,19 +178,26 @@ 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.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_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.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.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.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.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] -/ +/- Upstream audit output: 'RS.regts_sevenster_total_deligne_only' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ /-! ### The open sector: Proposition 3 @@ -166,107 +207,157 @@ its re-canonicalization, the per-move ledgers and the paired step 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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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_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.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_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.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.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.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_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.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.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.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_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.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.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.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.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.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.stepStatusLedger' depends on axioms: [propext, + Classical.choice, Quot.sound] -/ -/- Upstream audit output: 'RS.EdgeSubset.chainStatusLedger' 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 @@ -289,11 +380,13 @@ info: 'RS.traceZeta_rational_of_object' depends on axioms: [propext, Classical.c -/ /- -info: 'RS.scalarTrace_eq_zero_of_isNilpotent' 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] +info: 'RS.traceZeta_superSpectrum_of_object' depends on axioms: [propext, Classical.choice, + Quot.sound] -/ /-! ### The appendix's theorems, by type @@ -304,7 +397,8 @@ degree bound. -/ /- -info: @RS.traceZeta_rational_of_object : ∀ {A : Type u_2} [inst : CategoryTheory.Category.{u_1, u_2} A] +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] @@ -318,11 +412,13 @@ info: @RS.traceZeta_rational_of_object : ∀ {A : Type u_2} [inst : CategoryTheo 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 + 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] +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] @@ -358,7 +454,9 @@ info: @RS.objectFrobeniusTower : {A : Type u_2} → (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₀ + (∀ (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 index c85141633a..5b11467768 100644 --- a/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean +++ b/LeanPool/RegtsSevenster/RS/Assembly/BlueprintStatement.lean @@ -149,14 +149,18 @@ fields: 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 + 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) : + 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) : + (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 @@ -165,7 +169,8 @@ example {f : ClosedFragment → ℂ} {B : ℕ} (k ℓ : ℕ) (functional : Mixed 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 +example : @IsMixedPartitionFunctionTotalBounded = (fun (f : ClosedFragment → ℂ) (B : ℕ) => Nonempty + (TotalBoundedMixedModel f B) : (ClosedFragment → ℂ) → ℕ → Prop) := rfl /-! ## Edge-connection rank @@ -215,7 +220,8 @@ example : Prop := def RS.RegtsSevensterStatementTotal : Prop := ∀ (R : ℕ) (f : EdgeRankParameter R), IsMixedPartitionFunctionTotalBounded f.val R -/ -example : @RegtsSevensterStatementTotal = (∀ (R : ℕ) (f : EdgeRankParameter R), IsMixedPartitionFunctionTotalBounded f.val R : Prop) := rfl +example : @RegtsSevensterStatementTotal = (∀ (R : ℕ) (f : EdgeRankParameter R), + IsMixedPartitionFunctionTotalBounded f.val R : Prop) := rfl /- Upstream contract: @@ -248,15 +254,18 @@ 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] +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] +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) → + 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 @@ -287,16 +296,21 @@ example : ∀ (A : Type u_2) [_inst : CategoryTheory.Category.{u_1, u_2} A] /- 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] + [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] +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) → + 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 + [_inst_1 : CategoryTheory.MonoidalCategory A] → [CategoryTheory.RigidCategory A] → A → ℕ → ℕ → + A) := rfl /- Upstream contract: @@ -305,7 +319,8 @@ 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 + ∃ (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: @@ -313,18 +328,24 @@ 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] → 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) + ∀ (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] +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) → + ∀ (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 + [CategoryTheory.Limits.HasFiniteBiproducts A] → [CategoryTheory.RigidCategory A] → A → Prop) + := rfl /- Upstream contract: @@ -333,7 +354,8 @@ 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 + ∀ (f : Fin (k + 2) → CategoryTheory.Subobject Y), ¬StrictMono f : {C : Type u} → + [CategoryTheory.Category.{v, u} C] → C → ℕ → Prop) := rfl /- Upstream contract: @@ -342,14 +364,16 @@ def RS.ModerateLengthGrowth.{v, u} : (A : Type u) → 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] => +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.MonoidalCategory A] [CategoryTheory.SymmetricCategory A] + [CategoryTheory.Preadditive A] [CategoryTheory.Linear ℂ A] : Type (max (max 1 u_1) u_2) number of parameters: 6 fields: @@ -359,21 +383,28 @@ fields: 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.ω + 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) + [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 + (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) + [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 := + (preservesFiniteColimits : CategoryTheory.Limits.PreservesFiniteColimits ω) : + DeligneFibreFunctor A := DeligneFibreFunctor.mk ω braided additive linear faithful preservesFiniteLimits preservesFiniteColimits @@ -385,14 +416,17 @@ def RS.DeligneTheoremStatement.{u, v} : Prop := [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) + 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] +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 + HasScalarUnit A → (∃ (X : A), TensorGeneratedBy A X) → ModerateLengthGrowth A → Nonempty + (DeligneFibreFunctor A) : Prop) := rfl /-! ## The theorems of record @@ -464,14 +498,16 @@ 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⌋₊) ∧ + (∀ (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⌋₊) ∧ + (∀ (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 @@ -516,7 +552,8 @@ example : ∀ (θ : ℂ), mixedPartition (charPolyFunctional θ) loopGraph = θ /- Upstream contract: -mixedPartition_loopGraphCircle : ∀ (θ : ℂ), mixedPartition (charPolyFunctional θ) loopGraphCircle = 0 +mixedPartition_loopGraphCircle : ∀ (θ : ℂ), mixedPartition (charPolyFunctional θ) loopGraphCircle = + 0 -/ example : ∀ (θ : ℂ), mixedPartition (charPolyFunctional θ) loopGraphCircle = 0 := @mixedPartition_loopGraphCircle @@ -594,10 +631,12 @@ example : ∀ (f : ClosedFragment → ℂ), /- Upstream contract: regts_sevenster_minimum_deligne_only : DeligneTheoremStatement → - ∀ {R : ℕ} (f : EdgeRankParameter R), IsMixedPartitionFunctionTotalBounded f.val (minimumColourDimension f.val) + ∀ {R : ℕ} (f : EdgeRankParameter R), IsMixedPartitionFunctionTotalBounded f.val + (minimumColourDimension f.val) -/ example : DeligneTheoremStatement.{1, 1} → - ∀ {R : ℕ} (f : EdgeRankParameter R), IsMixedPartitionFunctionTotalBounded f.val (minimumColourDimension f.val) := + ∀ {R : ℕ} (f : EdgeRankParameter R), IsMixedPartitionFunctionTotalBounded f.val + (minimumColourDimension f.val) := @regts_sevenster_minimum_deligne_only @@ -630,7 +669,8 @@ example : DeligneTheoremStatement.{1, 1} → /- Upstream contract: -@minimumColourDimension_le_of_represents : ∀ {f : ClosedFragment → ℂ} {k ℓ : ℕ} (h : MixedFunctional k ℓ), +@minimumColourDimension_le_of_represents : ∀ {f : ClosedFragment → ℂ} {k ℓ : ℕ} (h : MixedFunctional + k ℓ), h.Represents f → minimumColourDimension f ≤ k + 2 * ℓ -/ example : ∀ {f : ClosedFragment → ℂ} {k ℓ : ℕ} (h : MixedFunctional k ℓ), @@ -640,10 +680,12 @@ example : ∀ {f : ClosedFragment → ℂ} {k ℓ : ℕ} (h : MixedFunctional k /- Upstream contract: @TotalBoundedMixedModel.dimension_eq_minimum : ∀ {f : ClosedFragment → ℂ} - (M : TotalBoundedMixedModel f (minimumColourDimension f)), M.k + 2 * M.ℓ = minimumColourDimension f + (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 := + (M : TotalBoundedMixedModel f (minimumColourDimension f)), M.k + 2 * M.ℓ = minimumColourDimension + f := @TotalBoundedMixedModel.dimension_eq_minimum @@ -670,18 +712,22 @@ example : ∀ {f : ClosedFragment → ℂ} /- Upstream contract: -@MixedFunctional.padColours : {k ℓ K L : ℕ} → MixedFunctional k ℓ → k ≤ K → ℓ ≤ L → MixedFunctional K L +@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 +@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 := + (K : ℂ) - 2 * ↑L = ↑k - 2 * ↑ℓ → ∀ {f : ClosedFragment → ℂ}, h.Represents f → (h.padColours hk + hℓ).Represents f := @MixedFunctional.padColours_represents @@ -698,28 +744,32 @@ example : ∀ {R : ℕ} (f : EdgeRankParameter R) (t : ℕ), 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 +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 +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 +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 +example : @minimumColourDimension = (fun f => sInf {d | IsMixedPartitionFunctionTotalBounded f d} : + (ClosedFragment → ℂ) → ℕ) := rfl /- Upstream contract: @@ -729,7 +779,8 @@ 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 * ↑ℓ) + 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 * ↑ℓ) diff --git a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseAssembly.lean b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseAssembly.lean index 991cd5951e..57a37f68c3 100644 --- a/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseAssembly.lean +++ b/LeanPool/RegtsSevenster/RS/Novel/Skein/ConverseAssembly.lean @@ -641,8 +641,7 @@ noncomputable def pairRelLeft {t : ℕ} {F G : Fragment (Fin t)} (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) : + (F.relabel (finCongr (by omega : t = 0 + t)))).RelTransitionSystem) : (leftSub (EdgeSubset.mk (closeJoin s₁ s₂) hc) ).RelTransitionSystem := relOfEq (leftSub_closeJoin hc hc₁).symm κ₁ @@ -657,8 +656,7 @@ noncomputable def pairRelRight {t : ℕ} {F G : Fragment (Fin t)} (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) : + (G.relabel (finCongr (by omega : t = t + 0)))).RelTransitionSystem) : (rightSub (EdgeSubset.mk (closeJoin s₁ s₂) hc) ).RelTransitionSystem := relOfEq (rightSub_closeJoin hc hc₂).symm κ₂ @@ -673,8 +671,7 @@ theorem openCircuitCount_pairRelLeft {t : ℕ} {F G : Fragment (Fin t)} (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) : + (F.relabel (finCongr (by omega : t = 0 + t)))).RelTransitionSystem) : (pairRelLeft (s₂ := s₂) hc₁ hc κ₁).openCircuitCount = κ₁.openCircuitCount := openCircuitCount_relOfEq _ κ₁ @@ -690,8 +687,7 @@ theorem openCircuitCount_pairRelRight {t : ℕ} (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) : + (G.relabel (finCongr (by omega : t = t + 0)))).RelTransitionSystem) : (pairRelRight (s₁ := s₁) hc₂ hc κ₂).openCircuitCount = κ₂.openCircuitCount := openCircuitCount_relOfEq _ κ₂